source: branches/ia32/compiler/nx1.lisp @ 7664

Last change on this file since 7664 was 7664, checked in by rme, 13 years ago

Uh, not yet.

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