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

Last change on this file since 11701 was 11701, checked in by gz, 11 years ago

Merge back some of the source location changes made in the trunk (in
particular this fixes the bug where source locations weren't actually
getting attached to inner functions, plus it makes the current source
note available in *nx-current-note*). Use *nx-curent-note* to record
the source note in compiler warnings.

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