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

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

Typecheck new bindings in nx1-env-body, if nx-declarations-typecheck is true. Remove the typechecking from nx1-typed-var-initform since no longer needed. Remove some bogus declarations found by compiling the system with typechecking declarations.

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