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

Last change on this file since 14740 was 14740, checked in by gb, 10 years ago

Wrap a THE around the acode generated for FF-CALL.

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