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

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

ftypes - r12467/r12500/r12512/r12514 from trunk

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