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

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

Backport compiler source location changes from trunk, mostly reorg and move file-compiler stuff out of the compiler, but also a fix to record a source note for inner functions

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 87.8 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 nil afunc))
1205  (setf (afunc-fn-refcount afunc) 1)
1206  (nx1-afunc-ref afunc))
1207
1208(defun nx1-compile-inner-function (name def original 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  (if *nx-current-code-note*
1219    (let* ((*nx-current-code-note* (nx-ensure-code-note def original *nx-current-code-note*)))
1220      (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p.
1221    (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)))
1222
1223(defun nx1-afunc-ref (afunc)
1224  (let ((op (if (afunc-inherited-vars afunc)
1225              (%nx1-operator closed-function)
1226              (%nx1-operator simple-function)))
1227        (ref (afunc-ref-form afunc)))
1228    (if ref
1229      (%rplaca ref op) ; returns ref
1230      (setf (afunc-ref-form afunc)
1231            (make-acode
1232             op
1233             afunc)))))
1234   
1235(defnx1 nx1-%function %function (form &aux symbol)
1236  (let ((sym (nx1-form form)))
1237    (if (and (eq (car sym) (%nx1-operator immediate))
1238             (setq symbol (cadr sym))
1239             (symbolp symbol))
1240      (progn
1241        (nx1-call-result-type symbol)   ; misnamed.  Checks for (un-)definedness.
1242        (make-acode (%nx1-default-operator) symbol))
1243      (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
1244
1245(defnx1 nx1-tagbody tagbody (&rest args)
1246  (let* ((newtags nil)
1247         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1248         (pending (make-pending-declarations))
1249         (*nx-bound-vars* *nx-bound-vars*)
1250         (catchvar (nx-new-temp-var pending "tagbody-catch-tag"))
1251         (indexvar (nx-new-temp-var pending "tagbody-tag-index"))
1252         (counter (list 0))
1253         (looplabel (cons nil nil))
1254         (*nx-tags* *nx-tags*))
1255    (dolist (form args)
1256      (when (atom form)
1257        (if (or (symbolp form) (integerp form))
1258          (if (assoc form newtags)
1259            (nx-error "Duplicate tag in TAGBODY: ~S." form)
1260            (push (list form nil counter catchvar nil nil) newtags))
1261          (nx-error "Illegal form in TAGBODY: ~S." form))))
1262    (dolist (tag (setq newtags (nreverse newtags)))
1263      (push tag *nx-tags*))
1264    (let* ((body nil)
1265           (*nx-loop-nesting-level* (1+ *nx-loop-nesting-level*)))
1266      (dolist (form args (setq body (nreverse body)))
1267        (push 
1268         (if (atom form)
1269           (let ((info (nx-tag-info form)))
1270             (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
1271             (cons (%nx1-operator tag-label) info))
1272           (nx1-form form))
1273         body))
1274      (if (eq 0 (%car counter))
1275        (make-acode (%nx1-operator local-tagbody) newtags body)
1276        (progn
1277          (nx-set-var-bits catchvar (logior (nx-var-bits catchvar)
1278                                            (%ilsl $vbitdynamicextent 1)))
1279          (nx-inhibit-register-allocation)   ; There are alternatives ...
1280          (dolist (tag (reverse newtags))
1281            (when (%cadr tag)
1282              (push 
1283               (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag))))
1284               body)))
1285          (make-acode
1286           (%nx1-operator let*)
1287           (list catchvar indexvar)
1288           (list (make-acode (%nx1-operator cons) *nx-nil* *nx-nil*) *nx-nil*)
1289           (make-acode
1290            (%nx1-operator local-tagbody)
1291            (list looplabel)
1292            (list
1293             (cons (%nx1-operator tag-label) looplabel)
1294             (make-acode
1295              (%nx1-operator if)
1296              (make-acode 
1297               (%nx1-operator setq-lexical)
1298               indexvar
1299               (make-acode 
1300                (%nx1-operator catch)
1301                (nx1-form (var-name catchvar)) 
1302                (make-acode
1303                 (%nx1-operator local-tagbody)
1304                 newtags
1305                 body)))
1306              (make-acode (%nx1-operator local-go) looplabel)
1307              *nx-nil*)))
1308           0))))))
1309
1310
1311
1312(defnx1 nx1-go go (tag)
1313  (multiple-value-bind (info closed)
1314                       (nx-tag-info tag)
1315    (unless info (nx-error "Can't GO to tag ~S." tag))
1316    (if (not closed)
1317      (let ((defnbackref (cdr (cdr (cdr (cdr info))))))
1318        (if (car defnbackref) 
1319          (rplaca (cdr defnbackref) t))
1320        (make-acode (%nx1-operator local-go) info))
1321      (progn
1322
1323        (make-acode
1324         (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed))))))
1325
1326
1327
1328
1329;;; address-expression should return a fixnum; that's our little
1330;;; secret.  result spec can be NIL, :void, or anything that an
1331;;; arg-spec can be.  arg-spec can be :double, :single, :address,
1332;;; :signed-doubleword, :unsigned-doubleword, :signed-fullword,
1333;;; :unsigned-fullword, :signed-halfword, :unsigned-halfword,
1334;;; :signed-byte, or :unsigned-byte
1335;;; On ppc64, :hybrid-int-float, :hybrid-float-float, and :hybrid-float-int
1336;;; can also be used to express some struct-by-value cases.
1337
1338(defparameter *arg-spec-keywords*
1339  '(:double-float :single-float :address :signed-doubleword
1340    :unsigned-doubleword :signed-fullword :unsigned-fullword
1341    :signed-halfword :unsigned-halfword :signed-byte :unsigned-byte
1342    :hybrid-int-float :hybrid-float-int :hybrid-float-float))
1343
1344
1345(defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec)
1346   (nx1-ff-call-internal
1347    address-expression arg-specs-and-result-spec
1348    (ecase (backend-name *target-backend*)
1349      (:linuxppc32 (%nx1-operator eabi-ff-call))
1350      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
1351      ((:darwinx8632 :linuxx8632 :win32 :solarisx8632) (%nx1-operator i386-ff-call))
1352      ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call)))))
1353
1354(defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec)
1355  (flet ((map-to-representation-types (list)
1356           (collect ((out))
1357             (do* ((l list (cddr l)))
1358                  ((null (cdr l))
1359                   (if l
1360                     (progn
1361                       (out (foreign-type-to-representation-type (car l)))
1362                       (out))
1363                     (error "Missing result type in ~s" list)))
1364               (out (foreign-type-to-representation-type (car l)))
1365               (out (cadr l))))))
1366          (nx1-ff-call-internal 
1367           idx (map-to-representation-types arg-specs-and-result-spec)
1368           (ecase (backend-name *target-backend*)
1369             (:linuxppc32 (%nx1-operator eabi-syscall))
1370             ((:darwinppc32 :darwinppc64 :linuxppc64)
1371              (%nx1-operator poweropen-syscall))
1372             ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall))
1373             ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall))))))
1374
1375(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator )
1376  (let* ((specs ())         
1377         (vals ())
1378         (register-spec-seen nil)
1379         (monitor (eq (car arg-specs-and-result-spec) :monitor-exception-ports))
1380         (arg-specs (butlast arg-specs-and-result-spec))
1381         (result-spec (car (last arg-specs-and-result-spec))))
1382    (if monitor
1383      (setq arg-specs (cdr arg-specs)))
1384    (unless (evenp (length arg-specs))
1385      (error "odd number of arg-specs"))
1386    (loop
1387      (when (null arg-specs) (return))
1388      (let* ((arg-keyword (pop arg-specs))
1389             (value (pop arg-specs)))
1390        (if (or (memq arg-keyword *arg-spec-keywords*)
1391                (typep arg-keyword 'unsigned-byte))
1392          (progn 
1393            (push arg-keyword specs)
1394            (push value vals))
1395          (if (eq arg-keyword :registers)
1396            (if register-spec-seen
1397              (error "duplicate :registers in ~s" arg-specs-and-result-spec)
1398              (progn
1399                (setq register-spec-seen t)
1400                (push arg-keyword specs)
1401                (push value vals)))
1402            (error "Unknown argument spec: ~s" arg-keyword)))))
1403    (unless (or (eq result-spec :void)
1404                (memq result-spec *arg-spec-keywords*))
1405      (error "Unknown result spec: ~s" result-spec))
1406    (make-acode operator
1407                (nx1-form address-expression)
1408                (nreverse specs)
1409                (mapcar #'nx1-form (nreverse vals))
1410                result-spec
1411                monitor)))
1412 
1413(defnx1 nx1-block block (blockname &body forms)
1414  (let* ((*nx-blocks* *nx-blocks*)
1415         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1416         (*nx-bound-vars* *nx-bound-vars*)
1417         (tagvar (nx-new-temp-var (make-pending-declarations)))
1418         (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar))
1419         (body nil))
1420    (push thisblock *nx-blocks*)
1421    (setq body (nx1-progn-body forms))
1422    (%rplacd thisblock nil)
1423    (let ((tagbits (nx-var-bits tagvar)))
1424      (if (not (%ilogbitp $vbitclosed tagbits))
1425        (if (neq 0 (%ilogand $vrefmask tagbits))
1426          (make-acode 
1427           (%nx1-operator local-block)
1428           thisblock
1429           body)
1430          body)
1431        (progn
1432          (nx-set-var-bits tagvar (%ilogior (%ilsl $vbitdynamicextent 1) tagbits))
1433          (nx-inhibit-register-allocation)   ; Could also set $vbitnoreg in all setqed vars, or keep track better
1434          (make-acode
1435           (%nx1-operator local-block)
1436           thisblock
1437           (make-acode
1438            (%nx1-operator let)
1439            (list tagvar)
1440            (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil)))
1441            (make-acode
1442             (%nx1-operator catch)
1443             (make-acode (%nx1-operator lexical-reference) tagvar)
1444             body)
1445            0)))))))
1446
1447(defnx1 nx1-return-from return-from (blockname &optional value)
1448  (multiple-value-bind (info closed)
1449                       (nx-block-info (setq blockname (nx-need-sym blockname)))
1450    (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname))
1451    (unless closed (nx-adjust-ref-count (cdr info)))
1452    (make-acode 
1453     (if closed
1454       (%nx1-operator throw)
1455       (%nx1-operator local-return-from))
1456     (if closed
1457       (nx1-symbol (var-name (cdr info)))
1458       info)
1459     (nx1-form value))))
1460
1461(defnx1 nx1-funcall ((funcall)) (func &rest args)
1462  (let ((name func))
1463    (if (and (consp name)
1464             (eq (%car name) 'function)
1465             (consp (%cdr name))
1466             (null (%cddr name))
1467             (or
1468              (if (symbolp (setq name (%cadr name)))
1469                (or (not (macro-function name *nx-lexical-environment*))
1470                    (nx-error "Can't funcall macro function ~s ." name)))
1471              (and (consp name) 
1472                   (or (when (eq (%car name) 'lambda)
1473                         (nx-note-source-transformation func name)
1474                         t)
1475                       (setq name (nx-need-function-name name))))))
1476      (nx1-form (cons name args))  ; This picks up call-next-method evil.
1477      (nx1-call (nx1-form func) args nil t))))
1478
1479(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
1480  (make-acode (%nx1-default-operator)
1481              (nx1-form value-form)
1482              (nx1-formlist args)))
1483
1484#|
1485(defun nx1-call-name (fn &aux (name (nx1-func-name fn)))
1486  (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name))))
1487    (make-acode (%nx1-operator immediate) name)
1488    (or name (nx1-form fn))))
1489|#
1490
1491(defnx1 nx1-compiler-let compiler-let (bindings &body forms)
1492  (let* ((vars nil)
1493         (varinits nil))
1494    (dolist (pair bindings)
1495      (push (nx-pair-name pair) vars)
1496      (push (eval (nx-pair-initform pair)) varinits))
1497   (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms))))
1498
1499(defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env)
1500  (let* ((fnames nil)
1501         (vars nil)
1502         (vals nil))
1503    (dolist (spec fnspecs (setq vals (nreverse vals)))
1504      (destructuring-bind (fname initform) spec
1505        (push (setq fname (nx-need-function-name fname)) fnames)
1506        (push (nx1-form initform) vals)))
1507    (let* ((new-env (new-lexical-environment old-env))
1508           (*nx-bound-vars* *nx-bound-vars*)
1509           (*nx-lexical-environment* new-env)
1510           (pending (make-pending-declarations)))
1511      (dolist (fname fnames)       
1512        (let ((var (nx-new-var pending (make-symbol (symbol-name fname)))))
1513          (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
1514                                         (nx-var-bits var)))
1515          (let ((afunc (make-afunc)))
1516            (setf (afunc-bits afunc) (%ilsl $fbitruntimedef 1))
1517            (setf (afunc-lfun afunc) var)
1518            (push var vars)
1519            (push (cons fname (cons 'function (cons afunc (var-name var)))) (lexenv.functions new-env)))))
1520      (make-acode
1521       (%nx1-operator let)
1522       vars
1523       vals
1524       (nx1-env-body body old-env)
1525       *nx-new-p2decls*))))
1526
1527(defun maybe-warn-about-nx1-alphatizer-binding (funcname)
1528  (when (and (symbolp funcname)
1529             (gethash funcname *nx1-alphatizers*))
1530    (nx1-whine :special-fbinding funcname)))
1531
1532(defnx1 nx1-flet flet (defs &body forms)
1533  (with-nx-declarations (pending)
1534    (let* ((env *nx-lexical-environment*)
1535           (*nx-lexical-environment* env)
1536           (*nx-bound-vars* *nx-bound-vars*)
1537           (new-env (new-lexical-environment env))
1538           (names nil)
1539           (funcs nil)
1540           (pairs nil)
1541           (fname nil)
1542           (name nil))
1543      (multiple-value-bind (body decls) (parse-body forms env nil)
1544        (nx-process-declarations pending decls)
1545        (dolist (def defs (setq names (nreverse names) funcs (nreverse funcs)))
1546          (destructuring-bind (funcname lambda-list &body flet-function-body) def
1547            (setq fname (nx-need-function-name funcname))
1548            (maybe-warn-about-nx1-alphatizer-binding funcname)
1549            (multiple-value-bind (body decls)
1550                                 (parse-body flet-function-body env)
1551              (let ((func (make-afunc))
1552                    (expansion `(lambda ,lambda-list
1553                                  ,@decls
1554                                  (block ,(if (consp funcname) (%cadr funcname) funcname)
1555                                    ,@body))))
1556                (nx-note-source-transformation def expansion)
1557                (setf (afunc-environment func) env
1558                      (afunc-lambdaform func) expansion)
1559                (push func funcs)
1560                (when (and *nx-next-method-var*
1561                             (eq funcname 'call-next-method)
1562                             (null *nx-call-next-method-function*))
1563                    (setq *nx-call-next-method-function* func))             
1564                (push (cons def func) pairs)
1565                (if (consp funcname)
1566                  (setq funcname fname))
1567                (push (setq name (make-symbol (symbol-name funcname))) names)
1568                (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env))))))
1569        (let ((vars nil)
1570              (rvars nil)
1571              (rfuncs nil))
1572          (dolist (sym names vars) (push (nx-new-var pending sym) vars))
1573          (nx-effect-other-decls pending new-env)
1574          (setq body (let* ((*nx-lexical-environment* new-env))
1575                       (nx1-dynamic-extent-functions vars new-env)
1576                       (nx1-env-body body env)))
1577          (dolist (pair pairs)
1578            (let ((afunc (cdr pair))
1579                  (var (pop vars)))
1580              (when (or (afunc-callers afunc)
1581                        (neq 0 (afunc-fn-refcount afunc))
1582                        (neq 0 (afunc-fn-downward-refcount afunc)))
1583                (push (nx1-compile-inner-function (%caar pair)
1584                                                  (afunc-lambdaform afunc) (%car pair)
1585                                                  afunc
1586                                                  (afunc-environment afunc))
1587                      rfuncs)
1588                (push var rvars))))
1589          (nx-reconcile-inherited-vars rfuncs)
1590          (dolist (f rfuncs) (nx1-afunc-ref f))
1591          (make-acode
1592           (%nx1-operator flet)
1593           rvars
1594           rfuncs
1595           body
1596           *nx-new-p2decls*))))))
1597
1598(defun nx1-dynamic-extent-functions (vars env)
1599  (let ((bits nil)
1600        (varinfo nil))
1601    (dolist (decl (lexenv.fdecls env))
1602      (let ((downward-guy (if (eq (cadr decl) 'dynamic-extent) (car decl))))
1603        (when downward-guy
1604          (multiple-value-bind (finfo afunc) (nx-lexical-finfo downward-guy)
1605            (when (and afunc 
1606                       (not (%ilogbitp $fbitdownward (setq bits (afunc-bits afunc))))
1607                       (setq varinfo (and (consp (%cdr finfo)) (nx-lex-info (%cddr finfo))))
1608                       (memq varinfo vars))
1609              (setf (afunc-bits afunc) 
1610                    (%ilogior 
1611                     bits 
1612                     (%ilsl $fbitdownward 1)
1613                     (%ilsl $fbitbounddownward 1)))
1614              (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo))))))))))
1615         
1616(defnx1 nx1-labels labels (defs &body forms)
1617  (with-nx-declarations (pending)
1618    (let* ((env *nx-lexical-environment*)
1619           (old-env (lexenv.parent-env env))
1620           (*nx-bound-vars* *nx-bound-vars*)
1621           (func nil)
1622           (funcs nil)
1623           (funcrefs nil)
1624           (bodies nil)
1625           (vars nil)
1626           (blockname nil)
1627           (fname nil)
1628           (name nil))
1629      (multiple-value-bind (body decls) (parse-body forms env nil)
1630        (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies)))
1631          (destructuring-bind (funcname lambda-list &body labels-function-body) def
1632            (maybe-warn-about-nx1-alphatizer-binding funcname)
1633            (push (setq func (make-afunc)) funcs)
1634            (setq blockname funcname)
1635            (setq fname (nx-need-function-name funcname))
1636            (when (consp funcname)
1637              (setq blockname (%cadr funcname) funcname fname))
1638            (let ((var (nx-new-var pending (setq name (make-symbol (symbol-name funcname))))))
1639              (nx-set-var-bits var (%ilsl $vbitignoreunused 1))
1640              (push var vars))
1641            (push func funcrefs)
1642            (multiple-value-bind (body decls)
1643                                 (parse-body labels-function-body old-env)
1644              (push (cons funcname (cons 'function (cons func name))) (lexenv.functions env))
1645              (let* ((expansion `(lambda ,lambda-list 
1646                                   ,@decls 
1647                                   (block ,blockname
1648                                     ,@body))))
1649                (nx-note-source-transformation def expansion)
1650                (setf (afunc-lambdaform func) expansion
1651                      (afunc-environment func) env)
1652                (push (list* funcname expansion def)
1653                      bodies)))))
1654        (nx1-dynamic-extent-functions vars env)
1655        (dolist (def bodies)
1656          (nx1-compile-inner-function (car def) (cadr def) (%cddr def) (setq func (pop funcs))))
1657        (nx-process-declarations pending decls)
1658        (nx-effect-other-decls pending env)
1659        (setq body (nx1-env-body body old-env))
1660        (nx-reconcile-inherited-vars funcrefs)
1661        (dolist (f funcrefs) (nx1-afunc-ref f))
1662        (make-acode
1663         (%nx1-operator labels)
1664         (nreverse vars)
1665         (nreverse funcrefs)
1666         body
1667         *nx-new-p2decls*)))))
1668
1669
1670
1671(defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p))
1672  (unless newval-p (setq newval offset offset 0))
1673  (make-acode
1674   (%nx1-operator %set-bit)
1675   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1676   (nx1-form offset)
1677   (nx1-form newval)))
1678               
1679(defnx1 nx1-set-xxx ((%set-ptr) (%set-long)  (%set-word) (%set-byte)
1680                     (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte))
1681        (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*))
1682  (unless new-val-p (setq newval offset offset 0))
1683  (make-acode
1684   (%nx1-operator %immediate-set-xxx)
1685   (case op
1686     (%set-ptr 0)
1687     (%set-word 2)
1688     (%set-unsigned-word (logior 32 2))
1689     (%set-byte 1)
1690     (%set-unsigned-byte (logior 32 1))
1691     (%set-unsigned-long (logior 32 4))
1692     (t 4))
1693   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1694   (nx1-form offset)
1695   (nx1-form newval)))
1696
1697(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) 
1698        (&whole w ptr offset newval &aux (op *nx-sfname*))
1699  (target-word-size-case
1700   (32 (nx1-treat-as-call w))
1701   (64
1702    (make-acode
1703     (%nx1-operator %immediate-set-xxx)
1704     (case op
1705       (%%set-signed-longlong 8)
1706       (t (logior 32 8)))
1707     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1708     (nx1-form offset)
1709     (nx1-form newval)))))
1710
1711
1712(defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0))
1713  (make-acode
1714   (%nx1-operator typed-form)
1715   'bit
1716   (make-acode
1717    (%nx1-operator %get-bit)
1718    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1719    (nx1-form offset))))
1720
1721(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong))
1722  (&whole w ptrform offsetform)
1723  (target-word-size-case
1724   (32 (nx1-treat-as-call w))
1725   (64
1726    (let* ((flagbits (case *nx-sfname*
1727                       (%%get-unsigned-longlong 8)
1728                       (%%get-signed-longlong (logior 32 8))))
1729           (signed (logbitp 5 flagbits)))
1730      (make-acode (%nx1-operator typed-form)
1731                  (if signed
1732                    '(signed-byte 64)
1733                    '(unsigned-byte 64))
1734                (make-acode 
1735                 (%nx1-operator immediate-get-xxx)
1736                 flagbits
1737                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1738                 (nx1-form offsetform)))))))
1739
1740(defnx1 nx1-get-xxx ((%get-long)  (%get-full-long)  (%get-signed-long)
1741                     (%get-fixnum) 
1742                     (%get-word) (%get-unsigned-word)
1743                     (%get-byte) (%get-unsigned-byte)
1744                     (%get-signed-word) 
1745                     (%get-signed-byte) 
1746                     (%get-unsigned-long))
1747  (ptrform &optional (offset 0))
1748  (let* ((sfname *nx-sfname*)
1749         (flagbits (case sfname
1750                     ((%get-long %get-full-long  %get-signed-long) (logior 4 32))
1751                     (%get-fixnum (logior 4 32 64))
1752                     
1753                     ((%get-word %get-unsigned-word) 2)
1754                     (%get-signed-word (logior 2 32))
1755                     ((%get-byte %get-unsigned-byte) 1)
1756                     (%get-signed-byte (logior 1 32))
1757                     (%get-unsigned-long 4)))
1758         (signed (logbitp 5 flagbits)))
1759    (declare (fixnum flagbits))
1760    (make-acode (%nx1-operator typed-form)
1761                (case (logand 15 flagbits)
1762                  (4 (if (logbitp 6 flagbits)
1763                       'fixnum
1764                       (if signed
1765                         '(signed-byte 32)
1766                         '(unsigned-byte 32))))
1767                  (2 (if signed
1768                       '(signed-byte 16)
1769                       '(unsigned-byte 16)))
1770                  (1 (if signed
1771                       '(signed-byte 8)
1772                       '(unsigned-byte 8))))
1773                (make-acode 
1774                 (%nx1-operator immediate-get-xxx)
1775                 flagbits
1776                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1777                 (nx1-form offset)))))
1778
1779(defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0))
1780  (make-acode
1781   (%nx1-operator %consmacptr%)
1782   (make-acode
1783    (%nx1-operator immediate-get-ptr)
1784    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1785    (nx1-form offset))))
1786
1787(defnx1 nx1-%get-float ((%get-single-float)
1788                        (%get-double-float)) (ptrform &optional (offset 0))
1789  (make-acode
1790   (%nx1-operator typed-form)
1791   (if (eq *nx-sfname* '%get-single-float)
1792     'single-float
1793     'double-float)
1794   (make-acode
1795    (%nx1-default-operator)
1796    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1797    (nx1-form offset))))
1798
1799(defnx1 nx1-%set-float ((%set-single-float)
1800                        (%set-double-float)) (&whole whole ptrform offset &optional (newval nil newval-p))
1801  (unless newval-p
1802    (setq newval offset
1803          offset 0))
1804    (make-acode
1805     (%nx1-operator typed-form)
1806     (if (eq *nx-sfname* '%set-single-float)
1807       'single-float
1808       'double-float)
1809     (make-acode
1810      (%nx1-default-operator)
1811      (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1812      (nx1-form offset)
1813      (nx1-form newval))))
1814
1815(defnx1 nx1-let let (pairs &body forms &environment old-env)
1816  (collect ((vars)
1817            (vals)
1818            (varbindings))
1819    (with-nx-declarations (pending)
1820      (multiple-value-bind (body decls)
1821                           (parse-body forms *nx-lexical-environment* nil)
1822        (nx-process-declarations pending decls)
1823        ;; Make sure that the initforms are processed in the outer
1824        ;; environment (in case any declaration handlers side-effected
1825        ;; the environment.)
1826       
1827        (let* ((*nx-lexical-environment* old-env))
1828          (dolist (pair pairs)
1829            (let* ((sym (nx-need-var (nx-pair-name pair)))
1830                   (var (nx-cons-var sym))
1831                   (val (nx1-typed-var-initform pending sym (nx-pair-initform pair)))
1832                   (binding (nx1-note-var-binding var val)))
1833              (vars var)
1834              (vals val)
1835              (when binding (varbindings binding)))))
1836        (let* ((*nx-bound-vars* *nx-bound-vars*)
1837               (varbindings (varbindings)))
1838          (dolist (v (vars)) (nx-init-var pending v))
1839          (let* ((form 
1840                  (make-acode 
1841                   (%nx1-operator let)
1842                   (vars)
1843                   (vals)
1844                   (progn
1845                     (nx-effect-other-decls pending *nx-lexical-environment*)
1846                     (nx1-env-body body old-env))
1847                 *nx-new-p2decls*)))
1848          (nx1-check-var-bindings varbindings)
1849          (nx1-punt-bindings (vars) (vals))
1850          form))))))
1851
1852
1853
1854;((lambda (lambda-list) . body) . args)
1855(defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*))
1856  (let* ((old-env body-environment)
1857         (arg-env *nx-lexical-environment*)
1858         (arglist nil)
1859         var-bound-vars
1860         vars vals vars* vals*)
1861    ;; If the lambda list contains &LEXPR, we can't do it.  Yet.
1862    (multiple-value-bind (ok req opttail resttail) (verify-lambda-list lambda-list)
1863      (declare (ignore req opttail))
1864      (when (and ok (eq (%car resttail) '&lexpr))
1865        (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args))))
1866    (let* ((*nx-lexical-environment* body-environment)
1867           (*nx-bound-vars* *nx-bound-vars*))
1868      (with-nx-declarations (pending)
1869        (multiple-value-bind (body decls) (parse-body body *nx-lexical-environment*)
1870          (nx-process-declarations pending decls)
1871          (multiple-value-bind (req opt rest keys auxen)
1872                               (nx-parse-simple-lambda-list pending lambda-list)
1873            (let* ((*nx-lexical-environment* arg-env))
1874              (setq arglist (nx1-formlist args)))
1875            (nx-effect-other-decls pending *nx-lexical-environment*)
1876            (setq body (nx1-env-body body old-env))
1877            (while req
1878              (when (null arglist)
1879                (nx-error "Not enough args ~S for (LAMBDA ~s ...)" args lambda-list))
1880              (let* ((var (pop req))
1881                     (val (pop arglist))
1882                     (binding (nx1-note-var-binding var val)))
1883                (push var vars)
1884                (push val vals)
1885                (when binding (push binding var-bound-vars))))
1886            (nx1-check-var-bindings var-bound-vars)
1887            (nx1-punt-bindings vars vals)
1888            (destructuring-bind (&optional optvars inits spvars) opt
1889              (while optvars
1890                (if arglist
1891                  (progn
1892                    (push (%car optvars) vars) (push (%car arglist) vals)
1893                    (when (%car spvars) (push (%car spvars) vars) (push *nx-t* vals)))
1894                  (progn
1895                    (push (%car optvars) vars*) (push (%car inits) vals*)
1896                    (when (%car spvars) (push (%car spvars) vars*) (push *nx-nil* vals*))))
1897                (setq optvars (%cdr optvars) spvars (%cdr spvars) inits (%cdr inits)
1898                      arglist (%cdr arglist))))
1899            (if arglist
1900              (when (and (not keys) (not rest))
1901                (nx-error "Extra args ~s for (LAMBDA ~s ...)" args lambda-list))
1902              (when rest
1903                (push rest vars*) (push *nx-nil* vals*)
1904                (nx1-punt-bindings (cons rest nil) (cons *nx-nil* nil))
1905                (setq rest nil)))
1906            (when keys
1907              (let* ((punt nil))
1908                (destructuring-bind (kallowother keyvars spvars inits keyvect) keys
1909                  (do* ((pairs arglist (%cddr pairs)))
1910                       ((null pairs))
1911                    (let* ((keyword (car pairs)))
1912                      (when (or (not (acode-p keyword))
1913                                (neq (acode-operator keyword) (%nx1-operator immediate))
1914                                (eq (%cadr keyword) :allow-other-keys))
1915                        (return (setq punt t)))))
1916                  (do* ((nkeys (length keyvect))
1917                        (keyargs (make-array  nkeys :initial-element nil))
1918                        (argl arglist (%cddr argl))
1919                        (n 0 (%i+ n 1))
1920                        idx arg hit)
1921                       ((null argl)
1922                        (unless rest
1923                          (while arglist
1924                            (push (%cadr arglist) vals)
1925                            (setq arglist (%cddr arglist))))
1926                        (dotimes (i (the fixnum nkeys))                     
1927                          (push (%car keyvars) vars*)
1928                          (push (or (%svref keyargs i) (%car inits)) vals*)
1929                          (when (%car spvars)
1930                            (push (%car spvars) vars*)
1931                            (push (if (%svref keyargs i) *nx-t* *nx-nil*) vals*))
1932                          (setq keyvars (%cdr keyvars) inits (%cdr inits) spvars (%cdr spvars)))
1933                        (setq keys hit))
1934                    (setq arg (%car argl))
1935                    (unless (and (not punt)
1936                                 (%cdr argl))
1937                      (let ((var (nx-new-temp-var pending)))
1938                        (when (or (null rest) (%ilogbitp $vbitdynamicextent (nx-var-bits rest)))
1939                          (nx-set-var-bits var (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits var))))
1940                        (setq body (make-acode
1941                                    (%nx1-operator debind)
1942                                    nil
1943                                    (make-acode 
1944                                     (%nx1-operator lexical-reference) var)
1945                                    nil 
1946                                    nil 
1947                                    rest 
1948                                    keys 
1949                                    auxen 
1950                                    nil 
1951                                    body 
1952                                    *nx-new-p2decls* 
1953                                    nil)
1954                              rest var keys nil auxen nil)
1955                        (return nil)))
1956                    (unless (or (setq idx (position (%cadr arg) keyvect))
1957                                (eq (%cadr arg) :allow-other-keys)
1958                                (and kallowother (symbolp (%cadr arg))))
1959                      (nx-error "Invalid keyword ~s in ~s for (LAMBDA ~S ...)"
1960                                (%cadr arg) args lambda-list))
1961                    (when (and idx (null (%svref keyargs idx)))
1962                      (setq hit t)
1963                      (%svset keyargs idx n))))))
1964            (destructuring-bind (&optional auxvars auxvals) auxen
1965              (let ((vars!% (nreconc vars* auxvars))
1966                    (vals!& (nreconc vals* auxvals)))
1967                (make-acode (%nx1-operator lambda-bind)
1968                            (append (nreverse vals) arglist)
1969                            (nreverse vars)
1970                            rest
1971                            keys
1972                            (list vars!% vals!&)
1973                            body
1974                            *nx-new-p2decls*)))))))))
1975
1976(defun nx-inhibit-register-allocation (&optional (why 0))
1977  (let ((afunc *nx-current-function*))
1978    (setf (afunc-bits afunc)
1979          (%ilogior (%ilsl $fbitnoregs 1)
1980                    why
1981                    (afunc-bits afunc)))))
1982
1983
1984
1985(defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body)
1986  (declare (ftype (function (t t t)) %define-ppc-lap-function))
1987  (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap")
1988  (setf (afunc-lfun *nx-current-function*) 
1989        (%define-ppc-lap-function name `((let ,bindings ,@body))
1990                                  (dpb (length bindings) $lfbits-numreq 0))))
1991
1992(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
1993  (declare (ftype (function (t t t t)) %define-x86-lap-function))
1994  (require "X86-LAP")
1995  (setf (afunc-lfun *nx-current-function*) 
1996        (%define-x86-lap-function name `((let ,bindings ,@body))
1997                                    (dpb (length bindings) $lfbits-numreq 0))))
1998
1999
2000
2001(defun nx1-env-body (body old-env)
2002  (do* ((form (nx1-progn-body body))
2003        (env *nx-lexical-environment* (lexenv.parent-env env)))
2004       ((or (eq env old-env) (null env)) form)
2005    (let ((vars (lexenv.variables env)))
2006      (if (consp vars)
2007        (dolist (var vars)
2008          (nx-check-var-usage var))))))
2009
2010(defnx1 nx1-let* (let*) (varspecs &body forms)
2011  (let* ((vars nil)
2012         (vals nil)
2013         (val nil)
2014         (var-bound-vars nil)
2015         (*nx-bound-vars* *nx-bound-vars*)
2016         (old-env *nx-lexical-environment*))
2017    (with-nx-declarations (pending)
2018      (multiple-value-bind (body decls)
2019                           (parse-body forms *nx-lexical-environment* nil)
2020        (nx-process-declarations pending decls)
2021        (dolist (pair varspecs)         
2022          (let* ((sym (nx-need-var (nx-pair-name pair)))
2023                 (var (progn 
2024                        (push (setq val (nx1-typed-var-initform pending sym (nx-pair-initform pair))) vals)
2025                        (nx-new-var pending sym)))
2026                 (binding (nx1-note-var-binding var val)))
2027            (when binding (push binding var-bound-vars))
2028            (push var vars)))
2029        (nx-effect-other-decls pending *nx-lexical-environment*)
2030        (let* ((result
2031                (make-acode 
2032                 (%nx1-default-operator)
2033                 (setq vars (nreverse vars))
2034                 (setq vals (nreverse vals))
2035                 (nx1-env-body body old-env)
2036                 *nx-new-p2decls*)))
2037          (nx1-check-var-bindings var-bound-vars)
2038          (nx1-punt-bindings vars vals)
2039          result)))))
2040
2041(defnx1 nx1-multiple-value-bind multiple-value-bind 
2042        (varspecs bindform &body forms)
2043  (if (= (length varspecs) 1)
2044    (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms))
2045    (let* ((vars nil)
2046           (*nx-bound-vars* *nx-bound-vars*)
2047           (old-env *nx-lexical-environment*)
2048           (mvform (nx1-form bindform)))
2049      (with-nx-declarations (pending)
2050        (multiple-value-bind (body decls)
2051                             (parse-body forms *nx-lexical-environment* nil)
2052          (nx-process-declarations pending decls)
2053          (dolist (sym varspecs)
2054            (push (nx-new-var pending sym t) vars))
2055          (nx-effect-other-decls pending *nx-lexical-environment*)
2056          (make-acode 
2057           (%nx1-operator multiple-value-bind)
2058           (nreverse vars)
2059           mvform
2060           (nx1-env-body body old-env)
2061           *nx-new-p2decls*))))))
2062
2063
2064;;; This isn't intended to be user-visible; there isn't a whole lot of
2065;;; sanity-checking applied to the subtag.
2066(defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p))
2067  (if init-p                            ; ensure that "init" is evaluated before miscobj is created.
2068    (make-acode (%nx1-operator %make-uvector)
2069                (nx1-form element-count)
2070                (nx1-form subtag)
2071                (nx1-form init))
2072    (make-acode (%nx1-operator %make-uvector)
2073                (nx1-form element-count)
2074                (nx1-form subtag))))
2075
2076(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset)
2077  (make-acode (%nx1-operator %lisp-word-ref)
2078              (nx1-form base)
2079              (nx1-form offset)))
2080
2081(defnx1 nx1-%single-to-double ((%single-to-double)) (arg)
2082  (make-acode (%nx1-operator %single-to-double)
2083              (nx1-form arg)))
2084
2085(defnx1 nx1-%double-to-single ((%double-to-single)) (arg)
2086  (make-acode (%nx1-operator %double-to-single)
2087              (nx1-form arg)))
2088
2089(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg)
2090  (make-acode (%nx1-operator %fixnum-to-double)
2091              (nx1-form arg)))
2092
2093(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg)
2094  (make-acode (%nx1-operator %fixnum-to-single)
2095              (nx1-form arg)))
2096
2097(defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p))
2098  (declare (ignore result))
2099  (if result-p
2100    (nx1-treat-as-call whole)
2101    (make-acode (%nx1-operator %double-float) (nx1-form arg))))
2102
2103(defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p))
2104  (declare (ignore result))       
2105  (if result-p
2106    (nx1-treat-as-call whole)
2107    (make-acode (%nx1-operator %single-float) (nx1-form arg))))
2108
2109
2110(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg)
2111  (make-acode (%nx1-default-operator) (nx1-form arg)))
2112       
2113(defnx1 nx1-ash (ash) (&whole call &environment env num amt)
2114  (let* ((unsigned-natural-type (target-word-size-case
2115                                 (32 '(unsigned-byte 32))
2116                                 (64 '(unsigned-byte 64))))
2117         (max (target-word-size-case (32 32) (64 64)))
2118         (maxbits (target-word-size-case
2119                   (32 29)
2120                   (64 60))))
2121    (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
2122          ((and (fixnump amt)
2123                (< amt 0))
2124           (if (nx-form-typep num 'fixnum env)
2125             (make-acode (%nx1-operator %iasr)
2126                         (make-acode (%nx1-operator fixnum)
2127                                     (- amt))
2128                         (nx1-form num))
2129             (if (nx-form-typep num unsigned-natural-type env)
2130               (make-acode (%nx1-operator natural-shift-right)
2131                           (nx1-form num)
2132                           (make-acode (%nx1-operator fixnum)
2133                                       (min (1- max) (- amt))))
2134               (nx1-treat-as-call call))))
2135          ((and (fixnump amt)
2136                (<= 0 amt maxbits)
2137                (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env)
2138                    (and (nx-form-typep num 'fixnum env)
2139                         (nx-trust-declarations env)
2140                         (subtypep *nx-form-type* 'fixnum))))
2141           (nx1-form `(%ilsl ,amt ,num)))
2142          ((and (fixnump amt)
2143                (< amt max)
2144                (nx-form-typep num unsigned-natural-type env)
2145                (nx-trust-declarations env)
2146                (subtypep *nx-form-type* unsigned-natural-type))
2147           (make-acode (%nx1-operator natural-shift-left)
2148                       (nx1-form num)
2149                       (nx1-form amt)))
2150          (t (nx1-treat-as-call call)))))
2151
2152   
2153       
2154(defun nx-badformat (&rest args)
2155 (nx-error "Bad argument format in ~S ." args))
2156
2157(defnx1 nx1-eval-when eval-when (when &body body)
2158  (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body)))
2159
2160(defnx1 nx1-misplaced (declare) (&rest args)
2161  (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
2162
Note: See TracBrowser for help on using the repository browser.