source: trunk/source/compiler/nx1.lisp @ 10321

Last change on this file since 10321 was 10321, checked in by gb, 12 years ago

Remove training wheels, start bumping fasl version.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 87.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;; Wimp out, but don't choke on (the (values ...) form)
20(defnx1 nx1-the the (&whole call typespec form &environment env)
21  (if (and (self-evaluating-p form)
22           (not (typep form typespec))
23           (progn (nx1-whine :type call) t))
24    (setq typespec t))
25  ;; Allow VALUES types here (or user-defined types that
26  ;; expand to VALUES types).
27  (let* ((ctype (values-specifier-type typespec)))
28    (if (typep ctype 'values-ctype)
29      (setq typespec '*)
30      (setq typespec (nx-target-type (type-specifier ctype)))))
31  (let* ((*nx-form-type* typespec)
32         (transformed (nx-transform form env)))
33    (if (and (consp transformed)
34             (eq (car transformed) 'the))
35      (setq transformed form))
36    ;; Doing this in this bizarre way may be a little easier
37    ;; to bootstrap.
38    (if (nx-the-typechecks env)
39      (make-acode
40       (%nx1-operator typed-form)
41       typespec
42       (nx1-transformed-form transformed env)
43       t)
44      (make-acode
45       (%nx1-operator typed-form)
46       typespec
47       (nx1-transformed-form transformed env)))))
48
49(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
50  (if (not (fixnump (setq offset (nx-get-fixnum offset))))
51    (nx1-treat-as-call whole)
52    (make-acode (%nx1-operator struct-ref)
53                (nx1-form structure)
54                (nx1-form offset))))
55
56(defnx1 nx1-struct-set struct-set (&whole whole structure offset newval)
57  (if (not (fixnump (setq offset (nx-get-fixnum offset))))
58    (nx1-treat-as-call whole)
59    (make-acode
60     (%nx1-operator struct-set)
61     (nx1-form structure)
62     (nx1-form offset)
63     (nx1-form newval))))
64
65(defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env)
66  (if (and (quoted-form-p type) (symbolp (cadr type)))
67    (make-acode (%nx1-operator istruct-typep)
68                (nx1-immediate :eq)
69                (nx1-form thing)
70                (nx1-form `(register-istruct-cell ,type)))
71    (nx1-treat-as-call whole)))
72
73(defnx1 nx1-make-list make-list (&whole whole size &rest keys &environment env)
74  (if (and keys 
75             (or 
76              (neq (list-length keys) 2)
77              (neq (nx-transform (%car keys) env) :initial-element)))
78    (nx1-treat-as-call whole)
79    (make-acode
80     (%nx1-operator make-list)
81     (nx1-form size)
82     (nx1-form (%cadr keys)))))
83
84;;; New semantics: expansion functions are defined in current lexical environment
85;;; vice null environment.  May be meaningless ...
86(defnx1 nx1-macrolet macrolet (defs &body body)
87  (let* ((old-env *nx-lexical-environment*)
88         (new-env (new-lexical-environment old-env)))
89    (dolist (def defs)
90      (destructuring-bind (name arglist &body mbody) def
91        (push 
92         (cons 
93          name
94          (cons
95           'macro
96           (multiple-value-bind (function warnings)
97               (compile-named-function (parse-macro name arglist mbody old-env) :name name :env old-env)
98             (setq *nx-warnings* (append *nx-warnings* warnings))
99             function)))
100         (lexenv.functions new-env))))
101    (let* ((*nx-lexical-environment* new-env))
102      (with-nx-declarations (pending)
103        (multiple-value-bind (body decls) (parse-body body new-env)
104          (nx-process-declarations pending decls)
105          (nx1-progn-body body))))))
106
107;;; Does SYMBOL-MACROLET allow declarations ?  Yes ...
108(defnx1 nx1-symbol-macrolet symbol-macrolet (defs &body forms)
109  (let* ((old-env *nx-lexical-environment*))
110    (with-nx-declarations (pending)
111      (multiple-value-bind (body decls)
112                           (parse-body forms old-env nil)
113        (nx-process-declarations pending decls)
114        (let ((env *nx-lexical-environment*)
115              (*nx-bound-vars* *nx-bound-vars*))
116          (dolist (def defs)
117            (destructuring-bind (sym expansion) def
118              (let* ((var (nx-new-var pending sym))
119                     (bits (nx-var-bits var)))
120                (when (%ilogbitp $vbitspecial bits)
121                  (nx-error "SPECIAL declaration applies to symbol macro ~s" sym))
122                (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits))
123                (setf (var-ea var) (cons :symbol-macro expansion)))))
124          (nx-effect-other-decls pending env)
125          (nx1-env-body body old-env))))))
126
127(defnx1 nx1-progn progn (&body args)
128  (nx1-progn-body args))
129
130(defnx1 nx1-with-c-frame with-c-frame (var &body body)
131  (make-acode (%nx1-operator with-c-frame)
132              (nx1-form `(let* ((,var (%foreign-stack-pointer)))
133                          ,@body))))
134
135(defnx1 nx1-with-variable-c-frame with-variable-c-frame (size var &body body)
136  (make-acode (%nx1-operator with-variable-c-frame)
137              (nx1-form size)
138              (nx1-form `(let* ((,var (%foreign-stack-pointer)))
139                          ,@body))))
140
141
142(defun nx1-progn-body (args)
143  (if (null (cdr args))
144    (nx1-form (%car args))
145    (make-acode (%nx1-operator progn) (nx1-formlist args))))
146
147(defnx1 nx1-unaryop ((%word-to-int) (uvsize)  (%reference-external-entry-point)
148                     (%symbol->symptr))
149        (arg)
150  (make-acode
151   (%nx1-default-operator) (nx1-form arg)))
152
153(defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) ()
154  (make-acode (%nx1-default-operator)))
155
156(defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) (base &optional (offset 0))
157  (make-acode (%nx1-default-operator)
158              (nx1-form base)
159              (nx1-form offset)))
160
161(defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag))
162  (arg)
163  (let* ((operator
164          (case *nx-sfname*
165            ((typecode) (%nx1-operator typecode))
166            ((lisptag) (%nx1-operator lisptag))
167            (( fulltag) (%nx1-operator fulltag)))))
168    (make-acode
169     operator (nx1-form arg))))
170       
171
172(defnx1 nx1-code-char ((code-char)) (arg &environment env)
173  (make-acode (if (nx-form-typep arg '(unsigned-byte 8) env)
174                (%nx1-operator %code-char)
175                (%nx1-operator code-char))
176              (nx1-form arg)))
177
178(defnx1 nx1-char-code ((char-code)) (arg &environment env)
179  (make-acode (if (nx-form-typep arg 'character env)
180                (%nx1-operator %char-code)
181                (%nx1-operator char-code))
182              (nx1-form arg)))
183
184(defnx1 nx1-cXr ((car) (cdr)) (arg &environment env)
185  (let* ((op (if (eq *nx-sfname* 'car) (%nx1-operator car) (%nx1-operator cdr)))
186         (inline-op (if (eq op (%nx1-operator car)) (%nx1-operator %car) (%nx1-operator %cdr))))
187    (make-acode (if (or (nx-inline-car-cdr env) (nx-form-typep arg 'list env))
188                  inline-op
189                  op)
190                (nx1-prefer-areg arg env))))
191
192(defnx1 nx1-rplacX ((rplaca) (rplacd)) (pairform valform &environment env)
193  (let* ((op (if (eq *nx-sfname* 'rplaca) (%nx1-operator rplaca) (%nx1-operator rplacd)))
194         (inline-op (if (eq op (%nx1-operator rplaca)) (%nx1-operator %rplaca) (%nx1-operator %rplacd))))
195    (make-acode (if (or (nx-inline-car-cdr env)
196                                 (and (nx-trust-declarations env)
197                                      (or (subtypep *nx-form-type* 'cons)
198                                          (nx-form-typep pairform 'cons env))))
199                  inline-op
200                  op)
201                (nx1-prefer-areg pairform env)
202                (nx1-form valform))))
203
204(defnx1 nx1-set-cXr ((set-car) (set-cdr)) (pairform valform &environment env)
205  (let* ((op (if (eq *nx-sfname* 'set-car) (%nx1-operator set-car) (%nx1-operator set-cdr)))
206         (inline-op (if (eq op (%nx1-operator set-car)) (%nx1-operator %rplaca) (%nx1-operator %rplacd)))
207         (inline-p (or (nx-inline-car-cdr env)
208                            (and (nx-trust-declarations env)
209                                 (or (subtypep *nx-form-type* 'cons)
210                                     (nx-form-typep pairform 'cons env)))))
211         (acode (make-acode (if inline-p inline-op op)
212                            (nx1-prefer-areg pairform env)
213                            (nx1-form valform))))
214    (if inline-p
215      (make-acode (if (eq op (%nx1-operator set-car)) (%nx1-operator %car) (%nx1-operator %cdr)) acode)
216      acode)))
217
218(defun nx1-cc-binaryop (op cc form1 form2)
219  (make-acode op (nx1-immediate cc) (nx1-form form1) (nx1-form form2)))
220
221(defnx1 nx1-ccEQ-unaryop ((characterp)  (endp) (consp) (base-char-p)) (arg)
222  (make-acode (%nx1-default-operator) (nx1-immediate :EQ) (nx1-form arg)))
223
224
225
226(defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq))
227        (form1 form2)
228  (nx1-cc-binaryop (%nx1-default-operator) :eq form1 form2))
229
230
231(defnx1 nx1-ccNE-binaryop ((neq))
232        (form1 form2)
233  (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2))
234
235(defnx1 nx1-logbitp ((logbitp)) (&whole w bitnum int &environment env)
236  (if (and (nx-form-typep bitnum
237                          (target-word-size-case (32 '(integer 0 29))
238                                                 (64 '(integer 0 60))) env)
239           (nx-form-typep int 'fixnum env))
240    (nx1-cc-binaryop (%nx1-operator %ilogbitp) :ne bitnum int)
241    (make-acode (%nx1-operator logbitp) (nx1-form bitnum) (nx1-form int))))
242
243
244 
245(defnx1 nx1-ccGT-unaryop ((int>0-p)) (arg)
246  (make-acode (%nx1-default-operator) (nx1-immediate :gt) (nx1-form arg)))
247
248(defnx1 nx1-macro-unaryop (multiple-value-list) (arg)
249  (make-acode
250   (%nx1-default-operator) (nx1-form arg)))
251
252(defnx1 nx1-atom ((atom)) (arg)
253  (nx1-form `(not (consp ,arg))))
254
255(defnx1 nx1-locally locally (&body forms)
256  (with-nx-declarations (pending)
257    (let ((env *nx-lexical-environment*))
258      (multiple-value-bind (body decls) (parse-body forms env  nil)
259        (nx-process-declarations pending decls)
260        (nx-effect-other-decls pending env)
261         (setq body (nx1-progn-body body))
262         (if decls
263           (make-acode (%nx1-operator %decls-body) body *nx-new-p2decls*)
264           body)))))
265
266(defnx1 nx1-%new-ptr (%new-ptr) (&whole whole size &optional clear-p)
267  (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p)))
268
269;;; This might also want to look at, e.g., the last form in a progn:
270;;;  (not (progn ... x)) => (progn ... (not x)), etc.
271(defnx1 nx1-negation ((not) (null)) (arg)
272  (if (nx1-negate-form (setq arg (nx1-form arg)))
273    arg
274    (make-acode (%nx1-operator not) (nx1-immediate :eq) arg)))
275
276(defun nx1-negate-form (form)
277  (let* ((subform (nx-untyped-form form)))
278    (when (and (acode-p subform) (typep (acode-operator subform) 'fixnum)) 
279      (let* ((op (acode-operator subform)))
280        (declare (fixnum op))
281        (when (logbitp operator-cc-invertable-bit op)
282          (%rplaca 
283           (%cdr (%cadr subform))
284           (acode-invert-condition-keyword (%cadr (%cadr subform))))
285          t)))))
286
287;;; This is called from pass 1, and therefore shouldn't mess with "puntable bindings"
288;;; (assuming, of course, that anyone should ...)
289(defun nx-untyped-form (form)
290  (while (and (consp form)
291              (eq (%car form) (%nx1-operator typed-form))
292              (null (nth 3 form)))
293    (setq form (%caddr form)))
294  form)
295
296
297
298(defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) (form)
299  (let* ((op *nx-sfname*))
300    (let* ((inner (case op 
301                       ((cdar caar) 'car)
302                       (t 'cdr)))
303              (outer (case op
304                       ((cdar cddr) 'cdr)
305                       (t 'car))))
306         (nx1-form `(,outer (,inner ,form))))))     
307
308(defnx1 nx1-%int-to-ptr ((%int-to-ptr)) (int)
309  (make-acode 
310   (%nx1-operator %consmacptr%)
311   (make-acode (%nx1-operator %immediate-int-to-ptr) 
312               (nx1-form int))))
313
314(defnx1 nx1-%ptr-to-int ((%ptr-to-int)) (ptr)
315  (make-acode 
316   (%nx1-operator %immediate-ptr-to-int)
317   (make-acode (%nx1-operator %macptrptr%) 
318               (nx1-form ptr))))
319
320(defnx1 nx1-%null-ptr-p ((%null-ptr-p)) (ptr)
321  (nx1-form `(%ptr-eql ,ptr (%int-to-ptr 0))))
322
323(defnx1 nx1-binop ( (%ilsl) (%ilsr) (%iasr)
324                   (cons) (%temp-cons))
325        (arg1 arg2)
326  (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2)))
327
328
329
330(defnx1 nx1-%misc-ref ((%misc-ref)) (v i)
331  (make-acode (%nx1-operator uvref) (nx1-form v) (nx1-form i)))
332
333
334
335
336(defnx1 nx1-schar ((schar)) (s i &environment env)
337  (make-acode (%nx1-operator %sbchar) (nx1-form s env) (nx1-form i env)))
338
339
340;;; This has to be ultra-bizarre because %schar is a macro.
341;;; %schar shouldn't be a macro.
342(defnx1 nx1-%schar ((%schar)) (&whole w arg idx &environment env)
343  (let* ((arg (nx-transform arg env))
344         (idx (nx-transform idx env))
345         (argvar (make-symbol "STRING"))
346         (idxvar (make-symbol "INDEX")))
347    (nx1-form `(let* ((,argvar ,arg)
348                      (,idxvar ,idx))
349                 (declare (optimize (speed 3) (safety 0)))
350                 (declare (simple-base-string ,argvar))
351                 (schar ,argvar ,idxvar)) env)))
352       
353(defnx1 nx1-%scharcode ((%scharcode)) (arg idx &environment env)
354  (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx)))
355
356
357(defnx1 nx1-svref ((svref) (%svref)) (&environment env v i)
358  (make-acode (if (nx-inhibit-safety-checking env)
359                (%nx1-operator %svref)
360                (%nx1-default-operator))
361              (nx1-prefer-areg v env)
362              (nx1-form i)))
363
364(defnx1 nx1-%slot-ref ((%slot-ref)) (instance idx)
365  (make-acode (%nx1-default-operator)
366              (nx1-form instance)
367              (nx1-form idx)))
368
369
370(defnx1 nx1-%err-disp ((%err-disp)) (&rest args)
371  (make-acode (%nx1-operator %err-disp)
372              (nx1-arglist args)))                       
373             
374(defnx1 nx1-macro-binop ((nth-value)) (arg1 arg2)
375  (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2)))
376
377(defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) (subtype uvector index)
378  (make-acode (%nx1-operator %typed-uvref) 
379                (nx1-form subtype) 
380                (nx1-form uvector) 
381                (nx1-form index)))
382
383
384
385(defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) (subtype uvector index newvalue)
386  (make-acode (%nx1-operator %typed-uvset) 
387                (nx1-form subtype) 
388                (nx1-form uvector) 
389                (nx1-form index) 
390                (nx1-form newvalue)))
391
392(defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2)
393  (nx-binary-boole-op w 
394                      env 
395                      arg-1 
396                      arg-2 
397                      (%nx1-operator %ilogior2)
398                      (%nx1-operator logior2)
399                      (%nx1-operator %natural-logior)))
400
401(defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2)
402  (nx-binary-boole-op w 
403                      env 
404                      arg-1 
405                      arg-2 
406                      (%nx1-operator %ilogxor2)
407                      (%nx1-operator logxor2)
408                      (%nx1-operator %natural-logxor)))
409
410(defnx1 nx1-logand-2 ((logand-2)) (&whole w &environment env arg-1 arg-2)
411  (nx-binary-boole-op w 
412                      env 
413                      arg-1 
414                      arg-2 
415                      (%nx1-operator %ilogand2)
416                      (%nx1-operator logand2)
417                      (%nx1-operator %natural-logand)))
418
419(defnx1 nx1-require ((require-simple-vector) (require-simple-string) (require-integer) (require-list)
420                     (require-fixnum) (require-real) (require-character) (require-number) (require-symbol) (require-s8) (require-u8) (require-s16) (require-u16) (require-s32) (require-u32) (require-s64) (require-u64))
421        (arg)
422  (make-acode (%nx1-default-operator) (nx1-form arg)))
423
424(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) ()
425  (make-acode (%nx1-default-operator)))
426
427(defnx1 nx1-throw (throw) (tag valuesform)
428  (make-acode (%nx1-operator throw) (nx1-form tag) (nx1-form valuesform)))
429
430
431;;; This is still used in inlining/lambda application.
432;;; The tricky parts of handling inlining reasonably have to do with
433;;; processing the body (including &optional/&key forms) in the environment
434;;; in which the lambda was defined (e.g., macros and symbol-macros.)
435;;; (I'm not sure that the traditional MCL/OpenMCL frontend handles
436;;; these cases 100% correctly, but it seems difficult to do this
437;;;  correctly without being able to jerk around with the environment,
438;;; for a variety of reasons.)
439;;; A lambda application - ((lambda ()) ...) is applied in the same
440;;; environment it's defined in, so the hard case involves inlining
441;;; functions whose environment may contain syntactic constructs
442;;; not present in the current environment (and which does -not- generally
443;;; contain whatever randomness is floating around at the point of
444;;; application.)
445(defun nx1-destructure (lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*))
446  (let* ((old-env body-env)
447         (*nx-bound-vars* *nx-bound-vars*)
448         (bindform (nx1-form bindform)))
449    (if (not (verify-lambda-list lambda-list t &whole-allowed-p))
450      (nx-error "Invalid lambda-list ~s" lambda-list)
451      (let* ((*nx-lexical-environment* body-env))
452        (with-nx-declarations (pending)
453          (multiple-value-bind (body decls)
454                               (parse-body forms *nx-lexical-environment*)
455            (nx-process-declarations pending decls)
456            (multiple-value-bind (req opt rest keys auxen whole)
457                                 (nx-parse-structured-lambda-list pending lambda-list nil &whole-allowed-p)
458              (nx-effect-other-decls pending *nx-lexical-environment*)
459              (make-acode
460               (%nx1-operator debind)
461               nil
462               bindform
463               req
464               opt
465               rest
466               keys
467               auxen
468               whole
469               (nx1-env-body body old-env)
470               *nx-new-p2decls*
471               cdr-p))))))))
472
473
474
475(defnx1 nx1-%setf-macptr ((%setf-macptr)) (ptr newval)
476  (let* ((arg1 (nx1-form ptr))
477         (arg2 (nx1-form newval)))
478    (if (and (consp arg1) (eq (%car arg1) (%nx1-operator %consmacptr%)))
479      ;e.g. (%setf-macptr (%null-ptr) <foo>)
480      (make-acode (%nx1-operator %consmacptr%)
481                  (make-acode (%nx1-operator progn)
482                              (list arg1 (make-acode (%nx1-operator %macptrptr%) arg2))))
483      (make-acode (%nx1-operator %setf-macptr) arg1 arg2))))
484
485(defnx1 nx1-%setf-double-float ((%setf-double-float)) (double-node double-val)
486  (make-acode (%nx1-operator %setf-double-float) (nx1-form double-node) (nx1-form double-val)))
487
488(defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) (short-node short-val)
489  (target-word-size-case
490   (32
491    (make-acode (%nx1-operator %setf-short-float) (nx1-form short-node) (nx1-form short-val)))
492   (64
493    (error "%SETF-SHORT-FLOAT makes no sense on 64-bit platforms."))))
494
495   
496(defnx1 nx1-%inc-ptr ((%inc-ptr)) (ptr &optional (increment 1))
497  (make-acode (%nx1-operator %consmacptr%)
498              (make-acode (%nx1-operator %immediate-inc-ptr)
499                          (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
500                          (nx1-form increment))))
501
502(defnx1 nx1-svset ((svset) (%svset)) (&environment env vector index value)
503  (make-acode (if (nx-inhibit-safety-checking env)
504                (%nx1-operator %svset)
505                (%nx1-default-operator))
506              (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value)))
507
508(defnx1 nx1-+ ((+-2)) (&whole whole &environment env num1 num2)
509  (let* ((f1 (nx1-form num1))
510         (f2 (nx1-form num2)))
511    (if (nx-binary-fixnum-op-p num1 num2 env t)
512      (let* ((fixadd (make-acode (%nx1-operator %i+) f1 f2))
513             (small-enough (target-word-size-case
514                            (32 '(signed-byte 28))
515                            (64 '(signed-byte 59)))))
516        (if (or (and (nx-acode-form-typep f1 small-enough env)
517                     (nx-acode-form-typep f2 small-enough env))
518                (nx-binary-fixnum-op-p num1 num2 env nil))
519          fixadd
520          (make-acode (%nx1-operator typed-form) 'integer (make-acode (%nx1-operator fixnum-overflow) fixadd))))
521      (if (and (nx-form-typep num1 'double-float env)
522               (nx-form-typep num2 'double-float env))
523        (nx1-form `(%double-float+-2 ,num1 ,num2))
524        (if (and (nx-form-typep num1 'short-float env)
525                 (nx-form-typep num2 'short-float env))
526          (nx1-form `(%short-float+-2 ,num1 ,num2))
527          (if (nx-binary-natural-op-p num1 num2 env nil)
528            (make-acode (%nx1-operator typed-form)
529                        (target-word-size-case
530                         (32 '(unsigned-byte 32))
531                         (64 '(unsigned-byte 64)))
532                        (make-acode (%nx1-operator %natural+) f1 f2))
533            (make-acode (%nx1-operator typed-form) 'number 
534                        (make-acode (%nx1-operator add2) f1 f2))))))))
535 
536(defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 ))
537        (f0 f1)
538  (make-acode (%nx1-operator typed-form) 'double-float
539              (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1))))
540
541
542(defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 ))
543        (f0 f1)
544  (make-acode (%nx1-operator typed-form) 'short-float
545              (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1))))
546
547
548(defnx1 nx1-*-2 ((*-2)) (&whole whole &environment env num1 num2)
549  (if (nx-binary-fixnum-op-p num1 num2 env)
550    (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env))
551    (if (and (nx-form-typep num1 'double-float env)
552             (nx-form-typep num2 'double-float env))
553      (nx1-form `(%double-float*-2 ,num1 ,num2))
554      (if (and (nx-form-typep num1 'short-float env)
555               (nx-form-typep num2 'short-float env))
556        (nx1-form `(%short-float*-2 ,num1 ,num2))
557        (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env))))))
558
559(defnx1 nx1-%negate ((%negate)) (&whole whole num &environment env)
560  (if (nx-form-typep num 'fixnum env)
561    (if (subtypep *nx-form-type* 'fixnum)
562      (make-acode (%nx1-operator %%ineg)(nx1-form num))
563      (make-acode (%nx1-operator %ineg) (nx1-form num)))
564    (make-acode (%nx1-operator minus1) (nx1-form num))))
565
566       
567(defnx1 nx1--2 ((--2)) (&whole whole &environment env num0 num1)       
568  (if (nx-binary-fixnum-op-p num0 num1 env t)
569    (let* ((f0 (nx1-form num0))
570           (f1 (nx1-form num1))
571           (fixsub (make-acode (%nx1-operator %i-) f0 f1))
572           (small-enough (target-word-size-case
573                          (32 '(signed-byte 28))
574                          (64 '(signed-byte 59)))))
575      (if (or (and (nx-acode-form-typep f0 small-enough env)
576                   (nx-acode-form-typep f1 small-enough env))
577              (nx-binary-fixnum-op-p num0 num1 env nil))
578        fixsub
579        (make-acode (%nx1-operator fixnum-overflow) fixsub)))
580    (if (and (nx-form-typep num0 'double-float env)
581             (nx-form-typep num1 'double-float env))
582      (nx1-form `(%double-float--2 ,num0 ,num1))
583      (if (and (nx-form-typep num0 'short-float env)
584               (nx-form-typep num1 'short-float env))
585        (nx1-form `(%short-float--2 ,num0 ,num1))
586        (if (nx-binary-natural-op-p num0 num1 env nil)
587          (make-acode (%nx1-operator %natural-)
588                      (nx1-form num0)
589                      (nx1-form num1))
590          (make-acode (%nx1-operator sub2)
591                      (nx1-form num0)
592                      (nx1-form num1)))))))
593     
594(defnx1 nx1-/-2 ((/-2)) (num0 num1 &environment env)
595  (if (and (nx-form-typep num0 'double-float env)
596           (nx-form-typep num1 'double-float env))
597    (nx1-form `(%double-float/-2 ,num0 ,num1))
598    (if (and (nx-form-typep num0 'short-float env)
599             (nx-form-typep num1 'short-float env))
600      (nx1-form `(%short-float/-2 ,num0 ,num1))
601      (make-acode (%nx1-operator div2) (nx1-form num0) (nx1-form num1)))))
602
603
604
605(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&whole whole &environment env num1 num2)
606  (let* ((op *nx-sfname*)
607         (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
608         (both-natural (nx-binary-natural-op-p num1 num2 env ))
609         (both-double-floats
610          (let* ((dfloat-1 (nx-form-typep num1 'double-float env))
611                 (dfloat-2 (nx-form-typep num2 'double-float env)))
612            (if dfloat-1 
613              (or dfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'double-float))))
614              (if dfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'double-float)))))))
615         (both-short-floats
616          (let* ((sfloat-1 (nx-form-typep num1 'short-float env))
617                 (sfloat-2 (nx-form-typep num2 'short-float env)))
618            (if sfloat-1 
619              (or sfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'short-float))))
620              (if sfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'short-float))))))))
621
622    (if (or both-fixnums both-double-floats both-short-floats both-natural)
623      (make-acode
624       (if both-fixnums
625         (%nx1-operator %i<>)
626         (if both-natural
627           (%nx1-operator %natural<>)
628           (if both-double-floats
629             (%nx1-operator double-float-compare)
630             (%nx1-operator short-float-compare))))
631       (make-acode
632        (%nx1-operator immediate)
633        (if (eq op '<-2)
634          :LT
635          (if (eq op '>=-2)
636            :GE
637            (if (eq op '<=-2)
638              :LE
639              :GT))))
640       (nx1-form num1)
641       (nx1-form num2))
642      (make-acode (%nx1-operator numcmp)
643                  (make-acode
644                   (%nx1-operator immediate)
645                   (if (eq op '<-2)
646                     :LT
647                     (if (eq op '>=-2)
648                       :GE
649                       (if (eq op '<=-2)
650                         :LE
651                         :GT))))
652                  (nx1-form num1)
653                  (nx1-form num2)))))
654
655(defnx1 nx1-num= ((=-2) (/=-2)) (&whole whole &environment env num1 num2 )
656  (let* ((op *nx-sfname*)
657         (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
658         (2-naturals (nx-binary-natural-op-p num1 num2 env))
659         (2-rats (and (nx-form-typep num1 'rational env)
660                      (nx-form-typep num2 'rational env)))
661         (2-dfloats (let* ((dfloat-1 (nx-form-typep num1 'double-float env))
662                           (dfloat-2 (nx-form-typep num2 'double-float env)))
663                      (if dfloat-1 
664                        (or dfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'double-float))))
665                        (if dfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'double-float)))))))
666         (2-sfloats (let* ((sfloat-1 (nx-form-typep num1 'short-float env))
667                           (sfloat-2 (nx-form-typep num2 'short-float env)))
668                      (if sfloat-1 
669                        (or sfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'short-float))))
670                        (if sfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'short-float)))))))
671         )
672    (if (and 2-naturals (not 2-fixnums))
673      (make-acode
674       (%nx1-operator %natural<>)
675       (make-acode
676        (%nx1-operator immediate)
677        (if (eq op '=-2)
678          :EQ
679          :NE))
680       (nx1-form num1)
681       (nx1-form num2))
682      (if 2-rats
683        (let* ((form `(,(if 2-fixnums 'eq 'eql) ,num1 ,num2))) 
684          (nx1-form (if (eq op '=-2) form `(not ,form))))
685        (if (or  2-dfloats 2-sfloats)
686          (make-acode 
687           (if 2-dfloats
688             (%nx1-operator double-float-compare)
689             (%nx1-operator short-float-compare))
690           (make-acode
691            (%nx1-operator immediate)     
692            (if (eq op '=-2)
693              :EQ
694              :NE))
695           (nx1-form num1)
696           (nx1-form num2))
697          (make-acode (%nx1-operator numcmp)
698                      (make-acode
699                       (%nx1-operator immediate)     
700                       (if (eq op '=-2)
701                         :EQ
702                         :NE))
703                      (nx1-form num1)
704                      (nx1-form num2)))))))
705             
706
707(defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value &environment env)
708  (make-acode (%nx1-operator uvset)
709              (nx1-form vector)
710              (nx1-form index)
711              (nx1-form value)))
712
713(defnx1 nx1-set-schar ((set-schar)) (&whole w s i v &environment env)
714  (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v)))
715
716
717
718(defnx1 nx1-%set-schar ((%set-schar)) (arg idx char &environment env)
719  (let* ((arg (nx-transform arg env))
720         (idx (nx-transform idx env))
721         (char (nx-transform char env))
722         (argvar (make-symbol "ARG"))
723         (idxvar (make-symbol "IDX"))
724         (charvar (make-symbol "CHAR")))
725    (nx1-form `(let* ((,argvar ,arg)
726                      (,idxvar ,idx)
727                      (,charvar ,char))
728                 (declare (optimize (speed 3) (safety 0)))
729                 (declare (simple-base-string ,argvar))
730                 (setf (schar ,argvar ,idxvar) ,charvar))
731              env)))
732
733(defnx1 nx1-%set-scharcode ((%set-scharcode)) (&whole w s i v)
734    (make-acode (%nx1-operator %set-scharcode)
735                (nx1-form s)
736                (nx1-form i)
737                (nx1-form v)))
738             
739
740(defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) (&rest args)
741  (make-acode (%nx1-default-operator) (nx1-formlist args)))
742
743
744
745(defnx1 nx1-%gvector ( (%gvector)) (&rest args)
746  (make-acode (%nx1-operator %gvector) (nx1-arglist args)))
747
748(defnx1 nx1-quote quote (form)
749  (nx1-immediate form))
750
751(defnx1 nx1-list* ((list*)) (first &rest rest)
752  (make-acode (%nx1-operator list*) (nx1-arglist (cons first rest) 1)))
753
754
755#|
756(defnx1 nx1-append ((append)) (&rest args)
757  (make-acode (%nx1-operator append) (nx1-arglist args 2)))
758
759
760|#
761
762(defnx1 nx1-or or (&whole whole &optional (firstform nil firstform-p) &rest moreforms)
763  (if (not firstform-p)
764    (nx1-form nil)
765    (if (null moreforms)
766      (nx1-form firstform)
767      (progn
768        (make-acode (%nx1-operator or) (nx1-formlist (%cdr whole)))))))
769
770(defun nx1-1d-vref (env arr dim0 &optional uvref-p)
771  (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env))
772         (string-p (unless simple-vector-p 
773                     (if (nx-form-typep arr 'string env)
774                       (or (nx-form-typep arr 'simple-string env)
775                           (return-from nx1-1d-vref (nx1-form `(char ,arr ,dim0)))))))
776         (simple-1d-array-p (unless (or simple-vector-p string-p) 
777                              (nx-form-typep arr '(simple-array * (*)) env)))
778         
779         (array-type (specifier-type  (nx-form-type arr env)))
780         (type-keyword (funcall
781                        (arch::target-array-type-name-from-ctype-function
782                         (backend-target-arch *target-backend*))
783                        array-type)))
784    (if (and simple-1d-array-p type-keyword)
785      (make-acode (%nx1-operator %typed-uvref) 
786                  (nx1-immediate type-keyword)
787                  (nx1-form arr)
788                  (nx1-form dim0))
789      (let* ((op (cond (simple-1d-array-p (%nx1-operator uvref))
790                       (string-p (%nx1-operator %sbchar))
791                       (simple-vector-p 
792                        (if (nx-inhibit-safety-checking env) (%nx1-operator %svref) (%nx1-operator svref)))
793                       (uvref-p (%nx1-operator uvref))
794                       (t (%nx1-operator %aref1)))))
795        (make-acode op (nx1-form arr) (nx1-form dim0))))))
796 
797(defnx1 nx1-aref ((aref)) (&whole whole &environment env arr &optional (dim0 nil dim0-p)
798                                  &rest other-dims)
799   (if (and dim0-p (null other-dims))
800     (nx1-1d-vref env arr dim0)
801     (nx1-treat-as-call whole)))
802
803(defnx1 nx1-uvref ((uvref)) (&environment env arr dim0)
804  (nx1-1d-vref env arr dim0 t))
805
806(defnx1 nx1-%aref2 ((%aref2)) (&whole whole &environment env arr i j)
807  ;; Bleah.  Breaks modularity.  Specialize later.
808  (target-arch-case
809   (:x8632
810    (return-from nx1-%aref2 (nx1-treat-as-call whole))))
811
812  (let* ((arch (backend-target-arch *target-backend*))
813         (ctype (specifier-type (nx-form-type arr env)))
814         (atype (if (csubtypep ctype (specifier-type '(array * (* *)))) ctype))
815         (simple-atype (if (and atype
816                                (csubtypep atype (specifier-type '(simple-array * (* *)))))
817                         atype))
818         (type-keyword (if atype
819                         (funcall
820                          (arch::target-array-type-name-from-ctype-function arch)
821                          atype))))
822    (if (and type-keyword simple-atype)
823      (let* ((dims (array-ctype-dimensions atype))
824             (dim0 (car dims))
825             (dim1 (cadr dims)))
826        (make-acode (%nx1-operator simple-typed-aref2)
827                    (nx1-form type-keyword)
828                    (nx1-form arr)
829                    (nx1-form i)
830                    (nx1-form j)
831                    (nx1-form (if (typep dim0 'fixnum) dim0))
832                    (nx1-form (if (typep dim1 'fixnum) dim1))))
833      (make-acode (%nx1-operator general-aref2)
834                  (nx1-form arr)
835                  (nx1-form i)
836                  (nx1-form j)))))
837
838(defnx1 nx1-%aref3 ((%aref3)) (&whole whole &environment env arr i j k)
839  ;; Bleah.  Breaks modularity.  Specialize later.
840  (target-arch-case
841   (:x8632
842    (return-from nx1-%aref3 (nx1-treat-as-call whole))))
843
844  (let* ((arch (backend-target-arch *target-backend*))
845         (ctype (specifier-type (nx-form-type arr env)))
846         (atype (if (csubtypep ctype (specifier-type '(array * (* * *)))) ctype))
847         (simple-atype (if (and atype
848                                (csubtypep atype (specifier-type '(simple-array * (* * *)))))
849                         atype))
850         (type-keyword (if atype
851                         (funcall
852                          (arch::target-array-type-name-from-ctype-function arch)
853                          atype))))
854    (if (and type-keyword simple-atype)
855      (let* ((dims (array-ctype-dimensions atype))
856             (dim0 (car dims))
857             (dim1 (cadr dims))
858             (dim2 (caddr dims)))
859        (make-acode (%nx1-operator simple-typed-aref3)
860                    (nx1-form type-keyword)
861                    (nx1-form arr)
862                    (nx1-form i)
863                    (nx1-form j)
864                    (nx1-form k)
865                    (nx1-form (if (typep dim0 'fixnum) dim0))
866                    (nx1-form (if (typep dim1 'fixnum) dim1))
867                    (nx1-form (if (typep dim2 'fixnum) dim2))))
868      (make-acode (%nx1-operator general-aref3)
869                  (nx1-form arr)
870                  (nx1-form i)
871                  (nx1-form j)
872                  (nx1-form k)))))
873
874(defun nx1-1d-vset (arr newval dim0 env)
875  (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env))
876         (string-p (unless simple-vector-p 
877                     (if (nx-form-typep arr 'string env)
878                       (or (nx-form-typep arr 'simple-string env)
879                           (return-from nx1-1d-vset (nx1-form `(set-char ,arr ,newval ,dim0)))))))
880         (simple-1d-array-p (unless (or simple-vector-p string-p) 
881                              (nx-form-typep arr '(simple-array * (*)) env)))
882         (array-type (specifier-type  (nx-form-type arr env)))
883         (type-keyword (funcall
884                        (arch::target-array-type-name-from-ctype-function
885                         (backend-target-arch *target-backend*))
886                        array-type)))
887         (if (and type-keyword simple-1d-array-p)
888             (make-acode (%nx1-operator %typed-uvset) 
889                         (nx1-immediate type-keyword)
890                         (nx1-form arr)
891                         (nx1-form newval)
892                         (nx1-form dim0))
893             (let* ((op (cond (simple-1d-array-p (%nx1-operator uvset))
894                              (string-p (%nx1-operator %set-sbchar))
895                              (simple-vector-p (if (nx-inhibit-safety-checking env) (%nx1-operator %svset) (%nx1-operator svset)))
896                              (t (%nx1-operator aset1)))))
897               (if op
898                   (make-acode
899                    op
900                    (nx1-form arr)
901                    (nx1-form newval)
902                    (nx1-form dim0))
903                   (nx1-form `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0)))))))
904
905(defnx1 nx1-aset ((aset)) (&whole whole 
906                                  arr newval 
907                                  &optional (dim0 nil dim0-p)
908                                  &environment env
909                                  &rest other-dims)
910   (if (and dim0-p (null other-dims))
911       (nx1-1d-vset arr newval dim0 env)
912       (nx1-treat-as-call whole)))
913           
914(defnx1 nx1-%aset2 ((%aset2)) (&whole whole &environment env arr i j new)
915  ;; Bleah.  Breaks modularity.  Specialize later.
916  (target-arch-case
917   (:x8632
918    (return-from nx1-%aset2 (nx1-treat-as-call whole))))
919
920  (let* ((arch (backend-target-arch *target-backend*))
921         (ctype (specifier-type (nx-form-type arr env)))
922         (atype (if (csubtypep ctype (specifier-type '(array * (* *)))) ctype))
923         (simple-atype (if (and atype
924                                (csubtypep atype (specifier-type '(simple-array * (* *)))))
925                         atype))
926         (type-keyword (if atype
927                         (funcall
928                          (arch::target-array-type-name-from-ctype-function arch)
929                          atype))))
930
931    (if (and type-keyword simple-atype)
932      (let* ((dims (array-ctype-dimensions atype))
933             (dim0 (car dims))
934             (dim1 (cadr dims)))
935        (make-acode (%nx1-operator simple-typed-aset2)
936                    (nx1-form type-keyword)
937                    (nx1-form arr)
938                    (nx1-form i)
939                    (nx1-form j)
940                    (nx1-form new)
941                    (nx1-form (if (typep dim0 'fixnum) dim0))
942                    (nx1-form (if (typep dim1 'fixnum) dim1))))
943            (make-acode (%nx1-operator general-aset2)
944                  (nx1-form arr)
945                  (nx1-form i)
946                  (nx1-form j)
947                  (nx1-form new)))))
948
949(defnx1 nx1-%aset3 ((%aset3)) (&whole whole &environment env arr i j k new)
950  ;; Bleah.  Breaks modularity.  Specialize later.
951  (target-arch-case
952   (:x8632
953    (return-from nx1-%aset3 (nx1-treat-as-call whole))))
954
955  (let* ((arch (backend-target-arch *target-backend*))
956         (ctype (specifier-type (nx-form-type arr env)))
957         (atype (if (csubtypep ctype (specifier-type '(array * (* * *)))) ctype))
958         (simple-atype (if (and atype
959                                (csubtypep atype (specifier-type '(simple-array * (* * *)))))
960                         atype))
961         (type-keyword (if atype
962                         (funcall
963                          (arch::target-array-type-name-from-ctype-function arch)
964                          atype))))
965
966    (if (and type-keyword simple-atype)
967      (let* ((dims (array-ctype-dimensions atype))
968             (dim0 (car dims))
969             (dim1 (cadr dims))
970             (dim2 (caddr dims)))
971        (make-acode (%nx1-operator simple-typed-aset3)
972                    (nx1-form type-keyword)
973                    (nx1-form arr)
974                    (nx1-form i)
975                    (nx1-form j)
976                    (nx1-form k)
977                    (nx1-form new)
978                    (nx1-form (if (typep dim0 'fixnum) dim0))
979                    (nx1-form (if (typep dim1 'fixnum) dim1))
980                    (nx1-form (if (typep dim2 'fixnum) dim2))))
981            (make-acode (%nx1-operator general-aset3)
982                  (nx1-form arr)
983                  (nx1-form i)
984                  (nx1-form j)
985                  (nx1-form k)
986                  (nx1-form new)))))
987
988(defnx1 nx1-prog1 (prog1 multiple-value-prog1) (save &body args 
989                                                     &aux (l (list (nx1-form save))))
990  (make-acode 
991   (%nx1-default-operator) 
992   (dolist (arg args (nreverse l))
993     (push (nx1-form arg) l))))
994
995(defnx1 nx1-if if (test true &optional false)
996  (if (null true)
997    (if (null false)
998      (return-from nx1-if (nx1-form `(progn ,test nil)))
999      (psetq test `(not ,test) true false false true)))
1000  (make-acode (%nx1-operator if)  (nx1-form test) (nx1-form true) (nx1-form false)))
1001
1002(defnx1 nx1-%debug-trap dbg (&optional arg)
1003  (make-acode (%nx1-operator %debug-trap) (nx1-form arg)))
1004       
1005(defnx1 nx1-setq setq (&whole whole &rest args &environment env &aux res)
1006  (when (%ilogbitp 0 (length args))
1007    (nx-error "Odd number of forms in ~s ." whole))
1008  (while args
1009    (let ((sym (nx-need-var (%car args) nil))
1010          (val (%cadr args)))
1011      (multiple-value-bind (expansion win) (macroexpand-1 sym env)
1012        (if win
1013            (push (nx1-form `(setf ,expansion ,val)) res)
1014            (multiple-value-bind (info inherited catchp)
1015                (nx-lex-info sym)
1016              (push
1017               (if (eq info :symbol-macro)
1018                   (progn
1019                     (nx-set-var-bits catchp
1020                                      (%ilogior
1021                                       (%ilsl $vbitsetq 1)
1022                                       (%ilsl $vbitreffed 1)
1023                                       (nx-var-bits catchp)))
1024                     (nx1-form `(setf ,inherited ,val)))
1025                   (let* ((valtype (nx-form-type val env))
1026                          (declared-type (nx-declared-type sym)))
1027                     (let ((*nx-form-type* declared-type))
1028                       (setq val (nx1-typed-form val env)))
1029                     (if (and info (neq info :special))
1030                         (progn
1031                           (nx1-check-assignment sym env)
1032                           (let ((inittype (var-inittype info)))
1033                             (if (and inittype (not (subtypep valtype inittype)))
1034                                 (setf (var-inittype info) nil)))
1035                           (if inherited
1036                               (nx-set-var-bits info (%ilogior (%ilsl $vbitsetq 1)
1037                                                               (%ilsl $vbitnoreg 1) ; I know, I know ... Someday ...
1038                                                               (nx-var-bits info)))
1039                               (nx-set-var-bits info (%ilogior2 (%ilsl $vbitsetq 1) (nx-var-bits info))))
1040                           (nx-adjust-setq-count info 1 catchp) ; In the hope that that day will come ...
1041                           (make-acode (%nx1-operator setq-lexical) info val))
1042                         (make-acode
1043                          (if (nx1-check-special-ref sym info)
1044                              (progn
1045                                (nx-record-xref-info :references sym)
1046                                (nx-record-xref-info :sets sym)
1047                                (if (nx-global-p sym env)
1048                                  (%nx1-operator global-setq)
1049                                  (%nx1-operator setq-special)))
1050                            (%nx1-operator setq-free)) ; Screw: no object lisp.  Still need setq-free ? For constants ?
1051                          (nx1-note-vcell-ref sym)
1052                          val))))
1053               res)))
1054        (setq args (%cddr args)))))
1055  (make-acode (%nx1-operator progn) (nreverse res)))
1056
1057;;; See if we're trying to setq something that's currently declared "UNSETTABLE"; whine if so.
1058;;; If we find a contour in which a "SETTABLE NIL" vdecl for the variable exists, whine.
1059;;; If we find a contour in which a "SETTABLE T" vdecl for the variable exists. or
1060;;;    the contour in which the variable's bound, return nil.
1061;;; Should find something ...
1062(defun nx1-check-assignment (sym env)
1063  (loop
1064    (unless (and env (istruct-typep env 'lexical-environment))
1065      (return))
1066    (dolist (decl (lexenv.vdecls env))
1067      (when (and (eq (car decl) sym)
1068               (eq (cadr decl) 'settable))
1069        (unless (cddr decl)
1070          (nx1-whine :unsettable sym))
1071        (return-from nx1-check-assignment nil)))
1072    (let ((vars (lexenv.variables env)))
1073      (unless (atom vars)
1074        (dolist (var vars)
1075          (when (eq (var-name var) sym) (return-from nx1-check-assignment nil)))))
1076    (setq env (lexenv.parent-env env))))
1077
1078;;; The cleanup issue is a little vague (ok, it's a -lot- vague) about the environment in
1079;;; which the load-time form is defined, although it apparently gets "executed in a null
1080;;; lexical environment".  Ignoring the fact that it's meaningless to talk of executing
1081;;; something in a lexical environment, we can sort of infer that it must also be defined
1082;;; in a null lexical environment.
1083
1084(defnx1 nx1-load-time-value (load-time-value) (&environment env form &optional read-only-p)
1085  ; Validate the "read-only-p" argument
1086  (if (and read-only-p (neq read-only-p t)) (require-type read-only-p '(member t nil)))
1087  ; Then ignore it.
1088  (if *nx-load-time-eval-token*
1089    (multiple-value-bind (function warnings)
1090                         (compile-named-function 
1091                          `(lambda () ,form)
1092                          ;; pass in the definition env for special decls
1093                          :env (definition-environment env)
1094                          :load-time-eval-token *nx-load-time-eval-token*
1095                          :target (backend-name *target-backend*))
1096      (setq *nx-warnings* (append *nx-warnings* warnings))
1097      (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function))))
1098    (nx1-immediate (eval form))))
1099
1100(defnx1 nx1-catch (catch) (operation &body body)
1101  (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body)))
1102
1103(defnx1 nx1-%badarg ((%badarg)) (badthing right-type)
1104  (make-acode (%nx1-operator %badarg2) 
1105              (nx1-form badthing) 
1106              (nx1-form (or (if (quoted-form-p right-type) (%typespec-id (cadr right-type))) right-type))))
1107
1108(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form)
1109  (if cleanup-form
1110    (make-acode (%nx1-operator unwind-protect) 
1111                (nx1-catch-body (list protected-form))
1112                (nx1-progn-body cleanup-form))
1113    (nx1-form protected-form)))
1114
1115(defnx1 nx1-progv progv (symbols values &body body)
1116  (make-acode (%nx1-operator progv) 
1117              (nx1-form `(check-symbol-list ,symbols))
1118              (nx1-form values) 
1119              (nx1-catch-body body)))
1120
1121(defun nx1-catch-body (body)
1122  (let* ((temp (new-lexical-environment *nx-lexical-environment*)))
1123    (setf (lexenv.variables temp) 'catch)
1124    (let* ((*nx-lexical-environment* (new-lexical-environment temp)))
1125      (nx1-progn-body body))))
1126
1127
1128
1129
1130                         
1131
1132(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &aux (orig args) (spread-p t))
1133  (if (null (%car (last (push arg args))))
1134    (setq spread-p nil args (butlast args)))
1135  (let ((name (nx1-func-name fn))
1136        (global nil))
1137    (if name
1138      (if (eq (%car fn) 'quote)
1139        (setq global t name (nx1-form fn))
1140        (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
1141          (when (and afunc (eq afunc *nx-call-next-method-function*))
1142            (setq name (if (or arg orig) 
1143                         '%call-next-method-with-args
1144                         '%call-next-method)
1145                         global t
1146                         args (cons (var-name *nx-next-method-var*) args)))))
1147      (setq name (nx1-form fn)))
1148    (nx1-call name args spread-p global)))
1149
1150(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (&whole call fn arg &rest args &aux (orig args))
1151  (push arg args)
1152  (let ((name (nx1-func-name fn))
1153        (global nil))
1154    (if name
1155      (if (eq (%car fn) 'quote)
1156        (setq global t name (nx1-form fn))
1157        (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
1158          (when (and afunc (eq afunc *nx-call-next-method-function*))
1159            (setq name (if (or arg orig) 
1160                         '%call-next-method-with-args
1161                         '%call-next-method)
1162                  global t
1163                  args (cons (var-name *nx-next-method-var*) args)))))
1164      (setq name (nx1-form fn)))
1165    (nx1-call name args 0 global)))
1166
1167
1168
1169(defnx1 nx1-%defun %defun (&whole w def &optional (doc nil doc-p) &environment env)
1170  (declare (ignorable doc doc-p))
1171  ; Pretty bogus.
1172  (if (and (consp def)
1173           (eq (%car def) 'nfunction)
1174           (consp (%cdr def))
1175           (symbolp (%cadr def)))
1176    (note-function-info (%cadr def) nil env))
1177  (nx1-treat-as-call w))
1178
1179
1180(defnx1 nx1-function function (arg &aux fn afunc)
1181  (if (symbolp arg)
1182    (progn
1183      (when (macro-function arg *nx-lexical-environment*)
1184        (nx-error
1185         "~S can't be used to reference lexically visible macro ~S." 
1186         'function arg))
1187      (if (multiple-value-setq (fn afunc) (nx-lexical-finfo arg))
1188        (progn
1189          (when afunc 
1190            (incf (afunc-fn-refcount afunc))
1191            (when (%ilogbitp $fbitbounddownward (afunc-bits afunc))
1192              (incf (afunc-fn-downward-refcount afunc))))
1193          (nx1-symbol (%cddr fn)))
1194        (progn
1195          (while (setq fn (assq arg *nx-synonyms*))
1196            (setq arg (%cdr fn)))
1197          (nx1-form `(%function ',arg)))))
1198    (if (and (consp arg) (eq (%car arg) 'setf))
1199      (nx1-form `(function ,(nx-need-function-name arg)))
1200      (nx1-ref-inner-function nil arg))))
1201
1202(defnx1 nx1-nfunction nfunction (name def)
1203 (nx1-ref-inner-function name def))
1204
1205(defun nx1-ref-inner-function (name def &optional afunc)
1206  (setq afunc (nx1-compile-inner-function name def afunc))
1207  (setf (afunc-fn-refcount afunc) 1)
1208  (nx1-afunc-ref afunc))
1209
1210(defun nx1-compile-inner-function (name def 
1211                                        &optional p (env *nx-lexical-environment*) 
1212                                        &aux (q *nx-current-function*))
1213  (unless p (setq p (make-afunc)))
1214  (setf (afunc-parent p) q)
1215  (setf (afunc-parent q) *nx-parent-function*)
1216  (setf (afunc-tags q) *nx-tags*)
1217  (setf (afunc-blocks q) *nx-blocks*)
1218  (setf (afunc-inner-functions q) (push p *nx-inner-functions*))
1219  (setf (lexenv.lambda env) q)
1220  (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p.
1221
1222(defun nx1-afunc-ref (afunc)
1223  (let ((op (if (afunc-inherited-vars afunc)
1224              (%nx1-operator closed-function)
1225              (%nx1-operator simple-function)))
1226        (ref (afunc-ref-form afunc)))
1227    (if ref
1228      (%rplaca ref op) ; returns ref
1229      (setf (afunc-ref-form afunc)
1230            (make-acode
1231             op
1232             afunc)))))
1233   
1234(defnx1 nx1-%function %function (form &aux symbol)
1235  (let ((sym (nx1-form form)))
1236    (if (and (eq (car sym) (%nx1-operator immediate))
1237             (setq symbol (cadr sym))
1238             (symbolp symbol))
1239      (progn
1240        (nx1-call-result-type symbol)   ; misnamed.  Checks for (un-)definedness.
1241        (make-acode (%nx1-default-operator) symbol))
1242      (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
1243
1244(defnx1 nx1-tagbody tagbody (&rest args)
1245  (let* ((newtags nil)
1246         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1247         (pending (make-pending-declarations))
1248         (*nx-bound-vars* *nx-bound-vars*)
1249         (catchvar (nx-new-temp-var pending "tagbody-catch-tag"))
1250         (indexvar (nx-new-temp-var pending "tagbody-tag-index"))
1251         (counter (list 0))
1252         (looplabel (cons nil nil))
1253         (*nx-tags* *nx-tags*))
1254    (dolist (form args)
1255      (when (atom form)
1256        (if (or (symbolp form) (integerp form))
1257          (if (assoc form newtags)
1258            (nx-error "Duplicate tag in TAGBODY: ~S." form)
1259            (push (list form nil counter catchvar nil nil) newtags))
1260          (nx-error "Illegal form in TAGBODY: ~S." form))))
1261    (dolist (tag (setq newtags (nreverse newtags)))
1262      (push tag *nx-tags*))
1263    (let* ((body nil)
1264           (*nx-loop-nesting-level* (1+ *nx-loop-nesting-level*)))
1265      (dolist (form args (setq body (nreverse body)))
1266        (push 
1267         (if (atom form)
1268           (let ((info (nx-tag-info form)))
1269             (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
1270             (cons (%nx1-operator tag-label) info))
1271           (nx1-form form))
1272         body))
1273      (if (eq 0 (%car counter))
1274        (make-acode (%nx1-operator local-tagbody) newtags body)
1275        (progn
1276          (nx-set-var-bits catchvar (logior (nx-var-bits catchvar)
1277                                            (%ilsl $vbitdynamicextent 1)))
1278          (nx-inhibit-register-allocation)   ; There are alternatives ...
1279          (dolist (tag (reverse newtags))
1280            (when (%cadr tag)
1281              (push 
1282               (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag))))
1283               body)))
1284          (make-acode
1285           (%nx1-operator let*)
1286           (list catchvar indexvar)
1287           (list (make-acode (%nx1-operator cons) *nx-nil* *nx-nil*) *nx-nil*)
1288           (make-acode
1289            (%nx1-operator local-tagbody)
1290            (list looplabel)
1291            (list
1292             (cons (%nx1-operator tag-label) looplabel)
1293             (make-acode
1294              (%nx1-operator if)
1295              (make-acode 
1296               (%nx1-operator setq-lexical)
1297               indexvar
1298               (make-acode 
1299                (%nx1-operator catch)
1300                (nx1-form (var-name catchvar)) 
1301                (make-acode
1302                 (%nx1-operator local-tagbody)
1303                 newtags
1304                 body)))
1305              (make-acode (%nx1-operator local-go) looplabel)
1306              *nx-nil*)))
1307           0))))))
1308
1309
1310
1311(defnx1 nx1-go go (tag)
1312  (multiple-value-bind (info closed)
1313                       (nx-tag-info tag)
1314    (unless info (nx-error "Can't GO to tag ~S." tag))
1315    (if (not closed)
1316      (let ((defnbackref (cdr (cdr (cdr (cdr info))))))
1317        (if (car defnbackref) 
1318          (rplaca (cdr defnbackref) t))
1319        (make-acode (%nx1-operator local-go) info))
1320      (progn
1321
1322        (make-acode
1323         (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed))))))
1324
1325
1326
1327
1328;;; address-expression should return a fixnum; that's our little
1329;;; secret.  result spec can be NIL, :void, or anything that an
1330;;; arg-spec can be.  arg-spec can be :double, :single, :address,
1331;;; :signed-doubleword, :unsigned-doubleword, :signed-fullword,
1332;;; :unsigned-fullword, :signed-halfword, :unsigned-halfword,
1333;;; :signed-byte, or :unsigned-byte
1334;;; On ppc64, :hybrid-int-float, :hybrid-float-float, and :hybrid-float-int
1335;;; can also be used to express some struct-by-value cases.
1336
1337(defparameter *arg-spec-keywords*
1338  '(:double-float :single-float :address :signed-doubleword
1339    :unsigned-doubleword :signed-fullword :unsigned-fullword
1340    :signed-halfword :unsigned-halfword :signed-byte :unsigned-byte
1341    :hybrid-int-float :hybrid-float-int :hybrid-float-float))
1342
1343
1344(defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec)
1345   (nx1-ff-call-internal
1346    address-expression arg-specs-and-result-spec
1347    (ecase (backend-name *target-backend*)
1348      (:linuxppc32 (%nx1-operator eabi-ff-call))
1349      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
1350      (:darwinx8632 (%nx1-operator i386-ff-call))
1351      ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664) (%nx1-operator ff-call)))))
1352
1353(defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec)
1354  (flet ((map-to-representation-types (list)
1355           (collect ((out))
1356             (do* ((l list (cddr l)))
1357                  ((null (cdr l))
1358                   (if l
1359                     (progn
1360                       (out (foreign-type-to-representation-type (car l)))
1361                       (out))
1362                     (error "Missing result type in ~s" list)))
1363               (out (foreign-type-to-representation-type (car l)))
1364               (out (cadr l))))))
1365          (nx1-ff-call-internal 
1366           idx (map-to-representation-types arg-specs-and-result-spec)
1367           (ecase (backend-name *target-backend*)
1368             (:linuxppc32 (%nx1-operator eabi-syscall))
1369             ((:darwinppc32 :darwinppc64 :linuxppc64)
1370              (%nx1-operator poweropen-syscall))
1371             (:darwinx8632 (%nx1-operator i386-syscall))
1372             ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664) (%nx1-operator syscall))))))
1373
1374(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator )
1375  (let* ((specs ())         
1376         (vals ())
1377         (register-spec-seen nil)
1378         (monitor (eq (car arg-specs-and-result-spec) :monitor-exception-ports))
1379         (arg-specs (butlast arg-specs-and-result-spec))
1380         (result-spec (car (last arg-specs-and-result-spec))))
1381    (if monitor
1382      (setq arg-specs (cdr arg-specs)))
1383    (unless (evenp (length arg-specs))
1384      (error "odd number of arg-specs"))
1385    (loop
1386      (when (null arg-specs) (return))
1387      (let* ((arg-keyword (pop arg-specs))
1388             (value (pop arg-specs)))
1389        (if (or (memq arg-keyword *arg-spec-keywords*)
1390                (typep arg-keyword 'unsigned-byte))
1391          (progn 
1392            (push arg-keyword specs)
1393            (push value vals))
1394          (if (eq arg-keyword :registers)
1395            (if register-spec-seen
1396              (error "duplicate :registers in ~s" arg-specs-and-result-spec)
1397              (progn
1398                (setq register-spec-seen t)
1399                (push arg-keyword specs)
1400                (push value vals)))
1401            (error "Unknown argument spec: ~s" arg-keyword)))))
1402    (unless (or (eq result-spec :void)
1403                (memq result-spec *arg-spec-keywords*))
1404      (error "Unknown result spec: ~s" result-spec))
1405    (make-acode operator
1406                (nx1-form address-expression)
1407                (nreverse specs)
1408                (mapcar #'nx1-form (nreverse vals))
1409                result-spec
1410                monitor)))
1411 
1412(defnx1 nx1-block block (blockname &body forms)
1413  (let* ((*nx-blocks* *nx-blocks*)
1414         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1415         (*nx-bound-vars* *nx-bound-vars*)
1416         (tagvar (nx-new-temp-var (make-pending-declarations)))
1417         (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar))
1418         (body nil))
1419    (push thisblock *nx-blocks*)
1420    (setq body (nx1-progn-body forms))
1421    (%rplacd thisblock nil)
1422    (let ((tagbits (nx-var-bits tagvar)))
1423      (if (not (%ilogbitp $vbitclosed tagbits))
1424        (if (neq 0 (%ilogand $vrefmask tagbits))
1425          (make-acode 
1426           (%nx1-operator local-block)
1427           thisblock
1428           body)
1429          body)
1430        (progn
1431          (nx-set-var-bits tagvar (%ilogior (%ilsl $vbitdynamicextent 1) tagbits))
1432          (nx-inhibit-register-allocation)   ; Could also set $vbitnoreg in all setqed vars, or keep track better
1433          (make-acode
1434           (%nx1-operator local-block)
1435           thisblock
1436           (make-acode
1437            (%nx1-operator let)
1438            (list tagvar)
1439            (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil)))
1440            (make-acode
1441             (%nx1-operator catch)
1442             (make-acode (%nx1-operator lexical-reference) tagvar)
1443             body)
1444            0)))))))
1445
1446(defnx1 nx1-return-from return-from (blockname &optional value)
1447  (multiple-value-bind (info closed)
1448                       (nx-block-info (setq blockname (nx-need-sym blockname)))
1449    (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname))
1450    (unless closed (nx-adjust-ref-count (cdr info)))
1451    (make-acode 
1452     (if closed
1453       (%nx1-operator throw)
1454       (%nx1-operator local-return-from))
1455     (if closed
1456       (nx1-symbol (var-name (cdr info)))
1457       info)
1458     (nx1-form value))))
1459
1460(defnx1 nx1-funcall ((funcall)) (func &rest args)
1461  (let ((name func))
1462    (if (and (consp name)
1463             (eq (%car name) 'function)
1464             (consp (%cdr name))
1465             (null (%cddr name))
1466             (or
1467              (if (symbolp (setq name (%cadr name)))
1468                (or (not (macro-function name *nx-lexical-environment*))
1469                    (nx-error "Can't funcall macro function ~s ." name)))
1470              (and (consp name) 
1471                   (or (eq (%car name) 'lambda)
1472                       (setq name (nx-need-function-name name))))))
1473      (nx1-form (cons name args))  ; This picks up call-next-method evil.
1474      (nx1-call (nx1-form func) args nil t))))
1475
1476(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
1477  (make-acode (%nx1-default-operator)
1478              (nx1-form value-form)
1479              (nx1-formlist args)))
1480
1481#|
1482(defun nx1-call-name (fn &aux (name (nx1-func-name fn)))
1483  (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name))))
1484    (make-acode (%nx1-operator immediate) name)
1485    (or name (nx1-form fn))))
1486|#
1487
1488(defnx1 nx1-compiler-let compiler-let (bindings &body forms)
1489  (let* ((vars nil)
1490         (varinits nil))
1491    (dolist (pair bindings)
1492      (push (nx-pair-name pair) vars)
1493      (push (eval (nx-pair-initform pair)) varinits))
1494   (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms))))
1495
1496(defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env)
1497  (let* ((fnames nil)
1498         (vars nil)
1499         (vals nil))
1500    (dolist (spec fnspecs (setq vals (nreverse vals)))
1501      (destructuring-bind (fname initform) spec
1502        (push (setq fname (nx-need-function-name fname)) fnames)
1503        (push (nx1-form initform) vals)))
1504    (let* ((new-env (new-lexical-environment old-env))
1505           (*nx-bound-vars* *nx-bound-vars*)
1506           (*nx-lexical-environment* new-env)
1507           (pending (make-pending-declarations)))
1508      (dolist (fname fnames)       
1509        (let ((var (nx-new-var pending (make-symbol (symbol-name fname)))))
1510          (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
1511                                         (nx-var-bits var)))
1512          (let ((afunc (make-afunc)))
1513            (setf (afunc-bits afunc) (%ilsl $fbitruntimedef 1))
1514            (setf (afunc-lfun afunc) var)
1515            (push var vars)
1516            (push (cons fname (cons 'function (cons afunc (var-name var)))) (lexenv.functions new-env)))))
1517      (make-acode
1518       (%nx1-operator let)
1519       vars
1520       vals
1521       (nx1-env-body body old-env)
1522       *nx-new-p2decls*))))
1523
1524(defun maybe-warn-about-nx1-alphatizer-binding (funcname)
1525  (when (and (symbolp funcname)
1526             (gethash funcname *nx1-alphatizers*))
1527    (nx1-whine :special-fbinding funcname)))
1528
1529(defnx1 nx1-flet flet (defs &body forms)
1530  (with-nx-declarations (pending)
1531    (let* ((env *nx-lexical-environment*)
1532           (*nx-lexical-environment* env)
1533           (*nx-bound-vars* *nx-bound-vars*)
1534           (new-env (new-lexical-environment env))
1535           (names nil)
1536           (funcs nil)
1537           (pairs nil)
1538           (fname nil)
1539           (name nil))
1540      (multiple-value-bind (body decls) (parse-body forms env nil)
1541        (nx-process-declarations pending decls)
1542        (dolist (def defs (setq names (nreverse names) funcs (nreverse funcs)))
1543          (destructuring-bind (funcname lambda-list &body flet-function-body) def
1544            (setq fname (nx-need-function-name funcname))
1545            (maybe-warn-about-nx1-alphatizer-binding funcname)
1546            (multiple-value-bind (body decls)
1547                                 (parse-body flet-function-body env)
1548              (let ((func (make-afunc)))
1549                (setf (afunc-environment func) env
1550                      (afunc-lambdaform func) `(lambda ,lambda-list
1551                                                     ,@decls
1552                                                     (block ,(if (consp funcname) (%cadr funcname) funcname)
1553                                                       ,@body)))
1554                (push func funcs)
1555                (when (and *nx-next-method-var*
1556                             (eq funcname 'call-next-method)
1557                             (null *nx-call-next-method-function*))
1558                    (setq *nx-call-next-method-function* func))             
1559                (push (cons funcname func) pairs)
1560                (if (consp funcname)
1561                  (setq funcname fname))
1562                (push (setq name (make-symbol (symbol-name funcname))) names)
1563                (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env))))))
1564        (let ((vars nil)
1565              (rvars nil)
1566              (rfuncs nil))
1567          (dolist (sym names vars) (push (nx-new-var pending sym) vars))
1568          (nx-effect-other-decls pending new-env)
1569          (setq body (let* ((*nx-lexical-environment* new-env))
1570                       (nx1-dynamic-extent-functions vars new-env)
1571                       (nx1-env-body body env)))
1572          (dolist (pair pairs)
1573            (let ((afunc (cdr pair))
1574                  (var (pop vars)))
1575              (when (or (afunc-callers afunc)
1576                        (neq 0 (afunc-fn-refcount afunc))
1577                        (neq 0 (afunc-fn-downward-refcount afunc)))
1578                (push (nx1-compile-inner-function (%car pair)
1579                                                  (afunc-lambdaform afunc)
1580                                                  afunc
1581                                                  (afunc-environment afunc))
1582                      rfuncs)
1583                (push var rvars))))
1584          (nx-reconcile-inherited-vars rfuncs)
1585          (dolist (f rfuncs) (nx1-afunc-ref f))
1586          (make-acode
1587           (%nx1-operator flet)
1588           rvars
1589           rfuncs
1590           body
1591           *nx-new-p2decls*))))))
1592
1593(defun nx1-dynamic-extent-functions (vars env)
1594  (let ((bits nil)
1595        (varinfo nil))
1596    (dolist (decl (lexenv.fdecls env))
1597      (let ((downward-guy (if (eq (cadr decl) 'dynamic-extent) (car decl))))
1598        (when downward-guy
1599          (multiple-value-bind (finfo afunc) (nx-lexical-finfo downward-guy)
1600            (when (and afunc 
1601                       (not (%ilogbitp $fbitdownward (setq bits (afunc-bits afunc))))
1602                       (setq varinfo (and (consp (%cdr finfo)) (nx-lex-info (%cddr finfo))))
1603                       (memq varinfo vars))
1604              (setf (afunc-bits afunc) 
1605                    (%ilogior 
1606                     bits 
1607                     (%ilsl $fbitdownward 1)
1608                     (%ilsl $fbitbounddownward 1)))
1609              (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo))))))))))
1610         
1611(defnx1 nx1-labels labels (defs &body forms)
1612  (with-nx-declarations (pending)
1613    (let* ((env *nx-lexical-environment*)
1614           (old-env (lexenv.parent-env env))
1615           (*nx-bound-vars* *nx-bound-vars*)
1616           (func nil)
1617           (funcs nil)
1618           (funcrefs nil)
1619           (bodies nil)
1620           (vars nil)
1621           (blockname nil)
1622           (fname nil)
1623           (name nil))
1624      (multiple-value-bind (body decls) (parse-body forms env nil)
1625        (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies)))
1626          (destructuring-bind (funcname lambda-list &body labels-function-body) def
1627            (maybe-warn-about-nx1-alphatizer-binding funcname)
1628            (push (setq func (make-afunc)) funcs)
1629            (setq blockname funcname)
1630            (setq fname (nx-need-function-name funcname))
1631            (when (consp funcname)
1632              (setq blockname (%cadr funcname) funcname fname))
1633            (let ((var (nx-new-var pending (setq name (make-symbol (symbol-name funcname))))))
1634              (nx-set-var-bits var (%ilsl $vbitignoreunused 1))
1635              (push var vars))
1636            (push func funcrefs)
1637            (multiple-value-bind (body decls)
1638                                 (parse-body labels-function-body old-env)
1639              (push (cons funcname (cons 'function (cons func name))) (lexenv.functions env))
1640              (let* ((expansion `(lambda ,lambda-list 
1641                                   ,@decls 
1642                                   (block ,blockname
1643                                     ,@body))))
1644                (setf (afunc-lambdaform func) expansion
1645                      (afunc-environment func) env)
1646                (push (cons funcname expansion)
1647                            bodies)))))
1648        (nx1-dynamic-extent-functions vars env)
1649        (dolist (def bodies)
1650          (nx1-compile-inner-function (car def) (cdr def) (setq func (pop funcs))))
1651        (nx-process-declarations pending decls)
1652        (nx-effect-other-decls pending env)
1653        (setq body (nx1-env-body body old-env))
1654        (nx-reconcile-inherited-vars funcrefs)
1655        (dolist (f funcrefs) (nx1-afunc-ref f))
1656        (make-acode
1657         (%nx1-operator labels)
1658         (nreverse vars)
1659         (nreverse funcrefs)
1660         body
1661         *nx-new-p2decls*)))))
1662
1663
1664
1665(defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p))
1666  (unless newval-p (setq newval offset offset 0))
1667  (make-acode
1668   (%nx1-operator %set-bit)
1669   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1670   (nx1-form offset)
1671   (nx1-form newval)))
1672               
1673(defnx1 nx1-set-xxx ((%set-ptr) (%set-long)  (%set-word) (%set-byte)
1674                     (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte))
1675        (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*))
1676  (unless new-val-p (setq newval offset offset 0))
1677  (make-acode
1678   (%nx1-operator %immediate-set-xxx)
1679   (case op
1680     (%set-ptr 0)
1681     (%set-word 2)
1682     (%set-unsigned-word (logior 32 2))
1683     (%set-byte 1)
1684     (%set-unsigned-byte (logior 32 1))
1685     (%set-unsigned-long (logior 32 4))
1686     (t 4))
1687   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1688   (nx1-form offset)
1689   (nx1-form newval)))
1690
1691(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) 
1692        (&whole w ptr offset newval &aux (op *nx-sfname*))
1693  (target-word-size-case
1694   (32 (nx1-treat-as-call w))
1695   (64
1696    (make-acode
1697     (%nx1-operator %immediate-set-xxx)
1698     (case op
1699       (%%set-signed-longlong 8)
1700       (t (logior 32 8)))
1701     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1702     (nx1-form offset)
1703     (nx1-form newval)))))
1704
1705
1706(defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0))
1707  (make-acode
1708   (%nx1-operator typed-form)
1709   'bit
1710   (make-acode
1711    (%nx1-operator %get-bit)
1712    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1713    (nx1-form offset))))
1714
1715(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong))
1716  (&whole w ptrform offsetform)
1717  (target-word-size-case
1718   (32 (nx1-treat-as-call w))
1719   (64
1720    (let* ((flagbits (case *nx-sfname*
1721                       (%%get-unsigned-longlong 8)
1722                       (%%get-signed-longlong (logior 32 8))))
1723           (signed (logbitp 5 flagbits)))
1724      (make-acode (%nx1-operator typed-form)
1725                  (if signed
1726                    '(signed-byte 64)
1727                    '(unsigned-byte 64))
1728                (make-acode 
1729                 (%nx1-operator immediate-get-xxx)
1730                 flagbits
1731                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1732                 (nx1-form offsetform)))))))
1733
1734(defnx1 nx1-get-xxx ((%get-long)  (%get-full-long)  (%get-signed-long)
1735                     (%get-fixnum) 
1736                     (%get-word) (%get-unsigned-word)
1737                     (%get-byte) (%get-unsigned-byte)
1738                     (%get-signed-word) 
1739                     (%get-signed-byte) 
1740                     (%get-unsigned-long))
1741  (ptrform &optional (offset 0))
1742  (let* ((sfname *nx-sfname*)
1743         (flagbits (case sfname
1744                     ((%get-long %get-full-long  %get-signed-long) (logior 4 32))
1745                     (%get-fixnum (logior 4 32 64))
1746                     
1747                     ((%get-word %get-unsigned-word) 2)
1748                     (%get-signed-word (logior 2 32))
1749                     ((%get-byte %get-unsigned-byte) 1)
1750                     (%get-signed-byte (logior 1 32))
1751                     (%get-unsigned-long 4)))
1752         (signed (logbitp 5 flagbits)))
1753    (declare (fixnum flagbits))
1754    (make-acode (%nx1-operator typed-form)
1755                (case (logand 15 flagbits)
1756                  (4 (if (logbitp 6 flagbits)
1757                       'fixnum
1758                       (if signed
1759                         '(signed-byte 32)
1760                         '(unsigned-byte 32))))
1761                  (2 (if signed
1762                       '(signed-byte 16)
1763                       '(unsigned-byte 16)))
1764                  (1 (if signed
1765                       '(signed-byte 8)
1766                       '(unsigned-byte 8))))
1767                (make-acode 
1768                 (%nx1-operator immediate-get-xxx)
1769                 flagbits
1770                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1771                 (nx1-form offset)))))
1772
1773(defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0))
1774  (make-acode
1775   (%nx1-operator %consmacptr%)
1776   (make-acode
1777    (%nx1-operator immediate-get-ptr)
1778    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1779    (nx1-form offset))))
1780
1781(defnx1 nx1-%get-float ((%get-single-float)
1782                        (%get-double-float)) (ptrform &optional (offset 0))
1783  (make-acode
1784   (%nx1-operator typed-form)
1785   (if (eq *nx-sfname* '%get-single-float)
1786     'single-float
1787     'double-float)
1788   (make-acode
1789    (%nx1-default-operator)
1790    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1791    (nx1-form offset))))
1792
1793(defnx1 nx1-%set-float ((%set-single-float)
1794                        (%set-double-float)) (&whole whole ptrform offset &optional (newval nil newval-p))
1795  (unless newval-p
1796    (setq newval offset
1797          offset 0))
1798    (make-acode
1799     (%nx1-operator typed-form)
1800     (if (eq *nx-sfname* '%set-single-float)
1801       'single-float
1802       'double-float)
1803     (make-acode
1804      (%nx1-default-operator)
1805      (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1806      (nx1-form offset)
1807      (nx1-form newval))))
1808
1809(defnx1 nx1-let let (pairs &body forms &environment old-env)
1810  (collect ((vars)
1811            (vals)
1812            (varbindings))
1813    (with-nx-declarations (pending)
1814      (multiple-value-bind (body decls)
1815                           (parse-body forms *nx-lexical-environment* nil)
1816        (nx-process-declarations pending decls)
1817        ;; Make sure that the initforms are processed in the outer
1818        ;; environment (in case any declaration handlers side-effected
1819        ;; the environment.)
1820       
1821        (let* ((*nx-lexical-environment* old-env))
1822          (dolist (pair pairs)
1823            (let* ((sym (nx-need-var (nx-pair-name pair)))
1824                   (var (nx-cons-var sym))
1825                   (val (nx1-typed-var-initform pending sym (nx-pair-initform pair)))
1826                   (binding (nx1-note-var-binding var val)))
1827              (vars var)
1828              (vals val)
1829              (when binding (varbindings binding)))))
1830        (let* ((*nx-bound-vars* *nx-bound-vars*)
1831               (varbindings (varbindings)))
1832          (dolist (v (vars)) (nx-init-var pending v))
1833          (let* ((form 
1834                  (make-acode 
1835                   (%nx1-operator let)
1836                   (vars)
1837                   (vals)
1838                   (progn
1839                     (nx-effect-other-decls pending *nx-lexical-environment*)
1840                     (nx1-env-body body old-env))
1841                 *nx-new-p2decls*)))
1842          (nx1-check-var-bindings varbindings)
1843          (nx1-punt-bindings (vars) (vals))
1844          form))))))
1845
1846
1847
1848;((lambda (lambda-list) . body) . args)
1849(defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*))
1850  (let* ((old-env body-environment)
1851         (arg-env *nx-lexical-environment*)
1852         (arglist nil)
1853         var-bound-vars
1854         vars vals vars* vals*)
1855    ;; If the lambda list contains &LEXPR, we can't do it.  Yet.
1856    (multiple-value-bind (ok req opttail resttail) (verify-lambda-list lambda-list)
1857      (declare (ignore req opttail))
1858      (when (and ok (eq (%car resttail) '&lexpr))
1859        (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args))))
1860    (let* ((*nx-lexical-environment* body-environment)
1861           (*nx-bound-vars* *nx-bound-vars*))
1862      (with-nx-declarations (pending)
1863        (multiple-value-bind (body decls) (parse-body body *nx-lexical-environment*)
1864          (nx-process-declarations pending decls)
1865          (multiple-value-bind (req opt rest keys auxen)
1866                               (nx-parse-simple-lambda-list pending lambda-list)
1867            (let* ((*nx-lexical-environment* arg-env))
1868              (setq arglist (nx1-formlist args)))
1869            (nx-effect-other-decls pending *nx-lexical-environment*)
1870            (setq body (nx1-env-body body old-env))
1871            (while req
1872              (when (null arglist)
1873                (nx-error "Not enough args ~S for (LAMBDA ~s ...)" args lambda-list))
1874              (let* ((var (pop req))
1875                     (val (pop arglist))
1876                     (binding (nx1-note-var-binding var val)))
1877                (push var vars)
1878                (push val vals)
1879                (when binding (push binding var-bound-vars))))
1880            (nx1-check-var-bindings var-bound-vars)
1881            (nx1-punt-bindings vars vals)
1882            (destructuring-bind (&optional optvars inits spvars) opt
1883              (while optvars
1884                (if arglist
1885                  (progn
1886                    (push (%car optvars) vars) (push (%car arglist) vals)
1887                    (when (%car spvars) (push (%car spvars) vars) (push *nx-t* vals)))
1888                  (progn
1889                    (push (%car optvars) vars*) (push (%car inits) vals*)
1890                    (when (%car spvars) (push (%car spvars) vars*) (push *nx-nil* vals*))))
1891                (setq optvars (%cdr optvars) spvars (%cdr spvars) inits (%cdr inits)
1892                      arglist (%cdr arglist))))
1893            (if arglist
1894              (when (and (not keys) (not rest))
1895                (nx-error "Extra args ~s for (LAMBDA ~s ,,,)" args lambda-list))
1896              (when rest
1897                (push rest vars*) (push *nx-nil* vals*)
1898                (nx1-punt-bindings (cons rest nil) (cons *nx-nil* nil))
1899                (setq rest nil)))
1900            (when keys
1901              (let* ((punt nil))
1902                (destructuring-bind (kallowother keyvars spvars inits keyvect) keys
1903                  (do* ((pairs arglist (%cddr pairs)))
1904                       ((null pairs))
1905                    (let* ((keyword (car pairs)))
1906                      (when (or (not (acode-p keyword))
1907                                (neq (acode-operator keyword) (%nx1-operator immediate))
1908                                (eq (%cadr keyword) :allow-other-keys))
1909                        (return (setq punt t)))))
1910                  (do* ((nkeys (length keyvect))
1911                        (keyargs (make-array  nkeys :initial-element nil))
1912                        (argl arglist (%cddr argl))
1913                        (n 0 (%i+ n 1))
1914                        idx arg hit)
1915                       ((null argl)
1916                        (unless rest
1917                          (while arglist
1918                            (push (%cadr arglist) vals)
1919                            (setq arglist (%cddr arglist))))
1920                        (dotimes (i (the fixnum nkeys))                     
1921                          (push (%car keyvars) vars*)
1922                          (push (or (%svref keyargs i) (%car inits)) vals*)
1923                          (when (%car spvars)
1924                            (push (%car spvars) vars*)
1925                            (push (if (%svref keyargs i) *nx-t* *nx-nil*) vals*))
1926                          (setq keyvars (%cdr keyvars) inits (%cdr inits) spvars (%cdr spvars)))
1927                        (setq keys hit))
1928                    (setq arg (%car argl))
1929                    (unless (and (not punt)
1930                                 (%cdr argl))
1931                      (let ((var (nx-new-temp-var pending)))
1932                        (when (or (null rest) (%ilogbitp $vbitdynamicextent (nx-var-bits rest)))
1933                          (nx-set-var-bits var (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits var))))
1934                        (setq body (make-acode
1935                                    (%nx1-operator debind)
1936                                    nil
1937                                    (make-acode 
1938                                     (%nx1-operator lexical-reference) var)
1939                                    nil 
1940                                    nil 
1941                                    rest 
1942                                    keys 
1943                                    auxen 
1944                                    nil 
1945                                    body 
1946                                    *nx-new-p2decls* 
1947                                    nil)
1948                              rest var keys nil auxen nil)
1949                        (return nil)))
1950                    (unless (or (setq idx (position (%cadr arg) keyvect))
1951                                (eq (%cadr arg) :allow-other-keys)
1952                                (and kallowother (symbolp (%cadr arg))))
1953                      (nx-error "Invalid keyword ~s in ~s for (LAMBDA ~S ...)"
1954                                (%cadr arg) args lambda-list))
1955                    (when (and idx (null (%svref keyargs idx)))
1956                      (setq hit t)
1957                      (%svset keyargs idx n))))))
1958            (destructuring-bind (&optional auxvars auxvals) auxen
1959              (let ((vars!% (nreconc vars* auxvars))
1960                    (vals!& (nreconc vals* auxvals)))
1961                (make-acode (%nx1-operator lambda-bind)
1962                            (append (nreverse vals) arglist)
1963                            (nreverse vars)
1964                            rest
1965                            keys
1966                            (list vars!% vals!&)
1967                            body
1968                            *nx-new-p2decls*)))))))))
1969
1970(defun nx-inhibit-register-allocation (&optional (why 0))
1971  (let ((afunc *nx-current-function*))
1972    (setf (afunc-bits afunc)
1973          (%ilogior (%ilsl $fbitnoregs 1)
1974                    why
1975                    (afunc-bits afunc)))))
1976
1977
1978
1979(defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body)
1980  (declare (ftype (function (t t t)) %define-ppc-lap-function))
1981  (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap")
1982  (setf (afunc-lfun *nx-current-function*) 
1983        (%define-ppc-lap-function name `((let ,bindings ,@body))
1984                                  (dpb (length bindings) $lfbits-numreq 0))))
1985
1986(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
1987  (declare (ftype (function (t t t t)) %define-x86-lap-function))
1988  (require "X86-LAP")
1989  (setf (afunc-lfun *nx-current-function*) 
1990        (%define-x86-lap-function name `((let ,bindings ,@body))
1991                                    (dpb (length bindings) $lfbits-numreq 0))))
1992
1993
1994
1995(defun nx1-env-body (body old-env)
1996  (do* ((form (nx1-progn-body body))
1997        (env *nx-lexical-environment* (lexenv.parent-env env)))
1998       ((or (eq env old-env) (null env)) form)
1999    (let ((vars (lexenv.variables env)))
2000      (if (consp vars)
2001        (dolist (var vars)
2002          (nx-check-var-usage var))))))
2003
2004(defnx1 nx1-let* (let*) (varspecs &body forms)
2005  (let* ((vars nil)
2006         (vals nil)
2007         (val nil)
2008         (var-bound-vars nil)
2009         (*nx-bound-vars* *nx-bound-vars*)
2010         (old-env *nx-lexical-environment*))
2011    (with-nx-declarations (pending)
2012      (multiple-value-bind (body decls)
2013                           (parse-body forms *nx-lexical-environment* nil)
2014        (nx-process-declarations pending decls)
2015        (dolist (pair varspecs)         
2016          (let* ((sym (nx-need-var (nx-pair-name pair)))
2017                 (var (progn 
2018                        (push (setq val (nx1-typed-var-initform pending sym (nx-pair-initform pair))) vals)
2019                        (nx-new-var pending sym)))
2020                 (binding (nx1-note-var-binding var val)))
2021            (when binding (push binding var-bound-vars))
2022            (push var vars)))
2023        (nx-effect-other-decls pending *nx-lexical-environment*)
2024        (let* ((result
2025                (make-acode 
2026                 (%nx1-default-operator)
2027                 (setq vars (nreverse vars))
2028                 (setq vals (nreverse vals))
2029                 (nx1-env-body body old-env)
2030                 *nx-new-p2decls*)))
2031          (nx1-check-var-bindings var-bound-vars)
2032          (nx1-punt-bindings vars vals)
2033          result)))))
2034
2035(defnx1 nx1-multiple-value-bind multiple-value-bind 
2036        (varspecs bindform &body forms)
2037  (if (= (length varspecs) 1)
2038    (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms))
2039    (let* ((vars nil)
2040           (*nx-bound-vars* *nx-bound-vars*)
2041           (old-env *nx-lexical-environment*)
2042           (mvform (nx1-form bindform)))
2043      (with-nx-declarations (pending)
2044        (multiple-value-bind (body decls)
2045                             (parse-body forms *nx-lexical-environment* nil)
2046          (nx-process-declarations pending decls)
2047          (dolist (sym varspecs)
2048            (push (nx-new-var pending sym t) vars))
2049          (nx-effect-other-decls pending *nx-lexical-environment*)
2050          (make-acode 
2051           (%nx1-operator multiple-value-bind)
2052           (nreverse vars)
2053           mvform
2054           (nx1-env-body body old-env)
2055           *nx-new-p2decls*))))))
2056
2057
2058;;; This isn't intended to be user-visible; there isn't a whole lot of
2059;;; sanity-checking applied to the subtag.
2060(defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p))
2061  (if init-p                            ; ensure that "init" is evaluated before miscobj is created.
2062    (make-acode (%nx1-operator %make-uvector)
2063                (nx1-form element-count)
2064                (nx1-form subtag)
2065                (nx1-form init))
2066    (make-acode (%nx1-operator %make-uvector)
2067                (nx1-form element-count)
2068                (nx1-form subtag))))
2069
2070(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset)
2071  (make-acode (%nx1-operator %lisp-word-ref)
2072              (nx1-form base)
2073              (nx1-form offset)))
2074
2075(defnx1 nx1-%single-to-double ((%single-to-double)) (arg)
2076  (make-acode (%nx1-operator %single-to-double)
2077              (nx1-form arg)))
2078
2079(defnx1 nx1-%double-to-single ((%double-to-single)) (arg)
2080  (make-acode (%nx1-operator %double-to-single)
2081              (nx1-form arg)))
2082
2083(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg)
2084  (make-acode (%nx1-operator %fixnum-to-double)
2085              (nx1-form arg)))
2086
2087(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg)
2088  (make-acode (%nx1-operator %fixnum-to-single)
2089              (nx1-form arg)))
2090
2091(defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p))
2092  (declare (ignore result))
2093  (if result-p
2094    (nx1-treat-as-call whole)
2095    (make-acode (%nx1-operator %double-float) (nx1-form arg))))
2096
2097(defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p))
2098  (declare (ignore result))       
2099  (if result-p
2100    (nx1-treat-as-call whole)
2101    (make-acode (%nx1-operator %single-float) (nx1-form arg))))
2102
2103
2104(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg)
2105  (make-acode (%nx1-default-operator) (nx1-form arg)))
2106       
2107(defnx1 nx1-ash (ash) (&whole call &environment env num amt)
2108  (let* ((unsigned-natural-type (target-word-size-case
2109                                 (32 '(unsigned-byte 32))
2110                                 (64 '(unsigned-byte 64))))
2111         (max (target-word-size-case (32 32) (64 64)))
2112         (maxbits (target-word-size-case
2113                   (32 29)
2114                   (64 60))))
2115    (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
2116          ((and (fixnump amt)
2117                (< amt 0))
2118           (if (nx-form-typep num 'fixnum env)
2119             (make-acode (%nx1-operator %iasr)
2120                         (make-acode (%nx1-operator fixnum)
2121                                     (- amt))
2122                         (nx1-form num))
2123             (if (nx-form-typep num unsigned-natural-type env)
2124               (make-acode (%nx1-operator natural-shift-right)
2125                           (nx1-form num)
2126                           (make-acode (%nx1-operator fixnum)
2127                                       (min (1- max) (- amt))))
2128               (nx1-treat-as-call call))))
2129          ((and (fixnump amt)
2130                (<= 0 amt maxbits)
2131                (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env)
2132                    (and (nx-form-typep num 'fixnum env)
2133                         (nx-trust-declarations env)
2134                         (subtypep *nx-form-type* 'fixnum))))
2135           (nx1-form `(%ilsl ,amt ,num)))
2136          ((and (fixnump amt)
2137                (< amt max)
2138                (nx-form-typep num unsigned-natural-type env)
2139                (nx-trust-declarations env)
2140                (subtypep *nx-form-type* unsigned-natural-type))
2141           (make-acode (%nx1-operator natural-shift-left)
2142                       (nx1-form num)
2143                       (nx1-form amt)))
2144          (t (nx1-treat-as-call call)))))
2145
2146   
2147       
2148(defun nx-badformat (&rest args)
2149 (nx-error "Bad argument format in ~S ." args))
2150
2151(defnx1 nx1-eval-when eval-when (when &body body)
2152  (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body)))
2153
2154(defnx1 nx1-misplaced (declare) (&rest args)
2155  (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
2156
Note: See TracBrowser for help on using the repository browser.