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

Last change on this file since 12045 was 12045, checked in by gz, 10 years ago

Extend the mechanism used to warn about undefined and duplicate functions in a
compilation unit to do the same for types, use it for types defined by
deftype/defstruct/defclass.

Also make proclaim-type err on invalid types and warn about undefined ones.

Tighten up assorted type/ftype declaration checking. This in turn unleashed
a bunch of test suite tests requiring errors on conflicts between DECLARATION
declarations and types, so I put in checks for those as well.

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