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

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

merge r12311 from trunk

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