source: branches/qres/ccl/compiler/nx1.lisp @ 14308

Last change on this file since 14308 was 14308, checked in by rme, 9 years ago

Merge r14305--r14307 from trunk. (Avoid spurious warnings about
unknown/forward-referenced types in DEFSTRUCT.)

See ITA bug 86893.

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