source: branches/working-0711/ccl/compiler/nx1.lisp @ 10996

Last change on this file since 10996 was 10996, checked in by gz, 13 years ago

Do not issue dup definition warnings for defuns inside conditionals, as in (unless (fboundp 'foo) (defun foo ...))

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