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

Last change on this file since 11212 was 11212, checked in by gz, 12 years ago

Source location support in the compiler:

COMPILE-NAMED-FUNCTION takes a new SOURCE-NOTES arg, which should be nil or a hash table mapping source forms to source notes. In the latter case, the compiler will do its best to track the source notes from the source all the way through code generation, and create a pc/source map, storing it as the 'pc-source-map property on the %lfun-info plist of the function and any inner functions. In addition, the compiler will store the source note of the lambda form on the 'function-source-note property of the function and any inner functions.

COMPILE-NAMED-FUNCTION also takes a new FUNCTION-NOTE arg which can be used to override the lambda source note indicated by SOURCE-NOTES.

Nothing actually passes in either of these arguments yet.

Also checking in some cases of acode-unwrapped-form -> acode-unwrapped-form-value, which have nothing to do with source locations but just help minimize diffs for easier merging.

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