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

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

In the frontend:

binary boolean operations assert their result's type.
logand of an unsigned natural integer and an integer constant is always
an unsigned natural (and the constant can be truncated to the word size.)

This helps with some examples involving (e.g.) DPB on word-sized integers;
it's likely that handling other cases require improvements in later phases.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 96.2 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
1311(defnx1 nx1-function function (arg &aux fn afunc)
1312  (if (symbolp arg)
1313    (progn
1314      (when (macro-function arg *nx-lexical-environment*)
1315        (nx-error
1316         "~S can't be used to reference lexically visible macro ~S." 
1317         'function arg))
1318      (if (multiple-value-setq (fn afunc) (nx-lexical-finfo arg))
1319        (progn
1320          (when afunc 
1321            (incf (afunc-fn-refcount afunc))
1322            (when (%ilogbitp $fbitbounddownward (afunc-bits afunc))
1323              (incf (afunc-fn-downward-refcount afunc))))
1324          (nx1-symbol (%cddr fn)))
1325        (progn
1326          (while (setq fn (assq arg *nx-synonyms*))
1327            (setq arg (%cdr fn)))
1328          (nx1-form `(%function ',arg)))))
1329    (if (and (consp arg) (eq (%car arg) 'setf))
1330      (nx1-form `(function ,(nx-need-function-name arg)))
1331      (nx1-ref-inner-function nil arg))))
1332
1333(defnx1 nx1-nfunction nfunction (name def)
1334 (nx1-ref-inner-function name def))
1335
1336(defun nx1-ref-inner-function (name def &optional afunc)
1337  (setq afunc (nx1-compile-inner-function name def afunc))
1338  (setf (afunc-fn-refcount afunc) 1)
1339  (nx1-afunc-ref afunc))
1340
1341(defun nx1-compile-inner-function (name def p
1342                                        &optional (env *nx-lexical-environment*)
1343                                        &aux (q *nx-current-function*))
1344  (unless p (setq p (make-afunc)))
1345  (setf (afunc-parent p) q)
1346  (setf (afunc-parent q) *nx-parent-function*)
1347  (setf (afunc-tags q) *nx-tags*)
1348  (setf (afunc-blocks q) *nx-blocks*)
1349  (setf (afunc-inner-functions q) (push p *nx-inner-functions*))
1350  (setf (lexenv.lambda env) q)
1351  (if *nx-current-code-note*
1352    (let* ((*nx-current-code-note* (nx-ensure-code-note def *nx-current-code-note*)))
1353      (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p.
1354    (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)))
1355
1356(defun nx1-afunc-ref (afunc)
1357  (let ((op (if (afunc-inherited-vars afunc)
1358              (%nx1-operator closed-function)
1359              (%nx1-operator simple-function)))
1360        (ref (acode-unwrapped-form (afunc-ref-form afunc))))
1361    (if ref
1362      (%rplaca ref op) ; returns ref
1363      (setf (afunc-ref-form afunc)
1364            (make-acode
1365             op
1366             afunc)))))
1367   
1368(defnx1 nx1-%function %function (form &aux symbol)
1369  (let ((sym (nx1-form form)))
1370    (if (and (eq (car sym) (%nx1-operator immediate))
1371             (setq symbol (cadr sym))
1372             (symbolp symbol))
1373      (let ((env *nx-lexical-environment*))
1374        (unless (or (nx1-find-call-def symbol env)
1375                    (find-ftype-decl symbol env)
1376                    (eq symbol *nx-global-function-name*))
1377          (nx1-whine :undefined-function symbol))
1378        (make-acode (%nx1-default-operator) symbol))
1379      (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
1380
1381(defnx1 nx1-tagbody tagbody (&rest args)
1382  (let* ((newtags nil)
1383         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1384         (pending (make-pending-declarations))
1385         (*nx-bound-vars* *nx-bound-vars*)
1386         (catchvar (nx-new-temp-var pending "tagbody-catch-tag"))
1387         (indexvar (nx-new-temp-var pending "tagbody-tag-index"))
1388         (counter (list 0))
1389         (looplabel (cons nil nil))
1390         (*nx-tags* *nx-tags*))
1391    (dolist (form args)
1392      (when (atom form)
1393        (if (or (symbolp form) (integerp form))
1394          (if (assoc form newtags)
1395            (nx-error "Duplicate tag in TAGBODY: ~S." form)
1396            (push (list form nil counter catchvar nil nil) newtags))
1397          (nx-error "Illegal form in TAGBODY: ~S." form))))
1398    (dolist (tag (setq newtags (nreverse newtags)))
1399      (push tag *nx-tags*))
1400    (let* ((body nil)
1401           (*nx-loop-nesting-level* (1+ *nx-loop-nesting-level*)))
1402      (dolist (form args (setq body (nreverse body)))
1403        (push 
1404         (if (atom form)
1405           (let ((info (nx-tag-info form)))
1406             (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
1407             (cons (%nx1-operator tag-label) info))
1408           (nx1-form form))
1409         body))
1410      (if (eq 0 (%car counter))
1411        (make-acode (%nx1-operator local-tagbody) newtags body)
1412        (progn
1413          (nx-set-var-bits catchvar (logior (nx-var-bits catchvar)
1414                                            (%ilsl $vbitdynamicextent 1)))
1415          (nx-inhibit-register-allocation)   ; There are alternatives ...
1416          (dolist (tag (reverse newtags))
1417            (when (%cadr tag)
1418              (push 
1419               (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag))))
1420               body)))
1421          (make-acode
1422           (%nx1-operator let*)
1423           (list catchvar indexvar)
1424           (list (make-acode (%nx1-operator cons) *nx-nil* *nx-nil*) *nx-nil*)
1425           (make-acode
1426            (%nx1-operator local-tagbody)
1427            (list looplabel)
1428            (list
1429             (cons (%nx1-operator tag-label) looplabel)
1430             (make-acode
1431              (%nx1-operator if)
1432              (make-acode 
1433               (%nx1-operator setq-lexical)
1434               indexvar
1435               (make-acode 
1436                (%nx1-operator catch)
1437                (nx1-form (var-name catchvar)) 
1438                (make-acode
1439                 (%nx1-operator local-tagbody)
1440                 newtags
1441                 body)))
1442              (make-acode (%nx1-operator local-go) looplabel)
1443              *nx-nil*)))
1444           0))))))
1445
1446
1447
1448(defnx1 nx1-go go (tag)
1449  (multiple-value-bind (info closed)
1450                       (nx-tag-info tag)
1451    (unless info (nx-error "Can't GO to tag ~S." tag))
1452    (if (not closed)
1453      (let ((defnbackref (cdr (cdr (cdr (cdr info))))))
1454        (if (car defnbackref) 
1455          (rplaca (cdr defnbackref) t))
1456        (make-acode (%nx1-operator local-go) info))
1457      (progn
1458
1459        (make-acode
1460         (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed))))))
1461
1462
1463
1464
1465;;; address-expression should return a fixnum; that's our little
1466;;; secret.  result spec can be NIL, :void, or anything that an
1467;;; arg-spec can be.  arg-spec can be :double, :single, :address,
1468;;; :signed-doubleword, :unsigned-doubleword, :signed-fullword,
1469;;; :unsigned-fullword, :signed-halfword, :unsigned-halfword,
1470;;; :signed-byte, or :unsigned-byte
1471;;; On ppc64, :hybrid-int-float, :hybrid-float-float, and :hybrid-float-int
1472;;; can also be used to express some struct-by-value cases.
1473
1474(defparameter *arg-spec-keywords*
1475  '(:double-float :single-float :address :signed-doubleword
1476    :unsigned-doubleword :signed-fullword :unsigned-fullword
1477    :signed-halfword :unsigned-halfword :signed-byte :unsigned-byte
1478    :hybrid-int-float :hybrid-float-int :hybrid-float-float))
1479
1480
1481(defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec)
1482   (nx1-ff-call-internal
1483    address-expression arg-specs-and-result-spec
1484    (ecase (backend-name *target-backend*)
1485      ((:linuxppc32 :linuxarm :darwinarm) (%nx1-operator eabi-ff-call))
1486      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
1487      ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call))
1488      ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call)))))
1489
1490(defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec)
1491  (flet ((map-to-representation-types (list)
1492           (collect ((out))
1493             (do* ((l list (cddr l)))
1494                  ((null (cdr l))
1495                   (if l
1496                     (progn
1497                       (out (foreign-type-to-representation-type (car l)))
1498                       (out))
1499                     (error "Missing result type in ~s" list)))
1500               (out (foreign-type-to-representation-type (car l)))
1501               (out (cadr l))))))
1502          (nx1-ff-call-internal 
1503           idx (map-to-representation-types arg-specs-and-result-spec)
1504           (ecase (backend-name *target-backend*)
1505             (:linuxppc32 (%nx1-operator eabi-syscall))
1506             ((:darwinppc32 :darwinppc64 :linuxppc64)
1507              (%nx1-operator poweropen-syscall))
1508             ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall))
1509             ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall))))))
1510
1511(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator )
1512  (let* ((specs ())         
1513         (vals ())
1514         (register-spec-seen nil)
1515         (arg-specs (butlast arg-specs-and-result-spec))
1516         (result-spec (car (last arg-specs-and-result-spec))))
1517    (unless (evenp (length arg-specs))
1518      (error "odd number of arg-specs"))
1519    (loop
1520      (when (null arg-specs) (return))
1521      (let* ((arg-keyword (pop arg-specs))
1522             (value (pop arg-specs)))
1523        (if (or (memq arg-keyword *arg-spec-keywords*)
1524                (typep arg-keyword 'unsigned-byte))
1525          (progn 
1526            (push arg-keyword specs)
1527            (push value vals))
1528          (if (eq arg-keyword :registers)
1529            (if register-spec-seen
1530              (error "duplicate :registers in ~s" arg-specs-and-result-spec)
1531              (progn
1532                (setq register-spec-seen t)
1533                (push arg-keyword specs)
1534                (push value vals)))
1535            (error "Unknown argument spec: ~s" arg-keyword)))))
1536    (unless (or (eq result-spec :void)
1537                (memq result-spec *arg-spec-keywords*))
1538      (error "Unknown result spec: ~s" result-spec))
1539    (make-acode operator
1540                (nx1-form address-expression)
1541                (nreverse specs)
1542                (mapcar #'nx1-form (nreverse vals))
1543                result-spec
1544                nil)))
1545 
1546(defnx1 nx1-block block (blockname &body forms)
1547  (let* ((*nx-blocks* *nx-blocks*)
1548         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1549         (*nx-bound-vars* *nx-bound-vars*)
1550         (tagvar (nx-new-temp-var (make-pending-declarations)))
1551         (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar))
1552         (body nil))
1553    (push thisblock *nx-blocks*)
1554    (setq body (nx1-progn-body forms))
1555    (%rplacd thisblock nil)
1556    (let ((tagbits (nx-var-bits tagvar)))
1557      (if (not (%ilogbitp $vbitclosed tagbits))
1558        (if (neq 0 (%ilogand $vrefmask tagbits))
1559          (make-acode 
1560           (%nx1-operator local-block)
1561           thisblock
1562           body)
1563          body)
1564        (progn
1565          (nx-set-var-bits tagvar (%ilogior (%ilsl $vbitdynamicextent 1) tagbits))
1566          (nx-inhibit-register-allocation)   ; Could also set $vbitnoreg in all setqed vars, or keep track better
1567          (make-acode
1568           (%nx1-operator local-block)
1569           thisblock
1570           (make-acode
1571            (%nx1-operator let)
1572            (list tagvar)
1573            (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil)))
1574            (make-acode
1575             (%nx1-operator catch)
1576             (nx-make-lexical-reference tagvar)
1577             body)
1578            0)))))))
1579
1580(defnx1 nx1-return-from return-from (blockname &optional value)
1581  (multiple-value-bind (info closed)
1582                       (nx-block-info (setq blockname (nx-need-sym blockname)))
1583    (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname))
1584    (unless closed (nx-adjust-ref-count (cdr info)))
1585    (make-acode 
1586     (if closed
1587       (%nx1-operator throw)
1588       (%nx1-operator local-return-from))
1589     (if closed
1590       (nx1-symbol (var-name (cdr info)))
1591       info)
1592     (nx1-form value))))
1593
1594(defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env)
1595  (let ((name (nx1-func-name func)))
1596    (if (or (null name)
1597            (and (symbolp name) (macro-function name env)))
1598      (nx1-typed-call (nx1-form func) args nil)
1599      (progn
1600        (when (consp name) ;; lambda expression
1601          (nx-note-source-transformation func name))
1602        ;; This picks up call-next-method evil.
1603        (nx1-form (let ((new-form (cons name args)))
1604                    (nx-note-source-transformation call new-form)
1605                    new-form))))))
1606
1607(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
1608  (make-acode (%nx1-default-operator)
1609              (nx1-form value-form)
1610              (nx1-formlist args)))
1611
1612(defnx1 nx1-compiler-let compiler-let (bindings &body forms)
1613  (let* ((vars nil)
1614         (varinits nil))
1615    (dolist (pair bindings)
1616      (push (nx-pair-name pair) vars)
1617      (push (eval (nx-pair-initform pair)) varinits))
1618   (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms))))
1619
1620(defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env)
1621  (let* ((fnames nil)
1622         (vars nil)
1623         (vals nil))
1624    (dolist (spec fnspecs (setq vals (nreverse vals)))
1625      (destructuring-bind (fname initform) spec
1626        (push (setq fname (nx-need-function-name fname)) fnames)
1627        (push (nx1-form initform) vals)))
1628    (let* ((new-env (new-lexical-environment old-env))
1629           (*nx-bound-vars* *nx-bound-vars*)
1630           (*nx-lexical-environment* new-env)
1631           (pending (make-pending-declarations)))
1632      (dolist (fname fnames)       
1633        (let ((var (nx-new-var pending (make-symbol (symbol-name fname)))))
1634          (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
1635                                         (nx-var-bits var)))
1636          (let ((afunc (make-afunc)))
1637            (setf (afunc-bits afunc) (%ilsl $fbitruntimedef 1))
1638            (setf (afunc-lfun afunc) var)
1639            (push var vars)
1640            (push (cons fname (cons 'function (cons afunc (var-name var)))) (lexenv.functions new-env)))))
1641      (make-acode
1642       (%nx1-operator let)
1643       vars
1644       vals
1645       (nx1-env-body body old-env)
1646       *nx-new-p2decls*))))
1647
1648(defun maybe-warn-about-nx1-alphatizer-binding (funcname)
1649  (when (and (symbolp funcname)
1650             (gethash funcname *nx1-alphatizers*))
1651    (nx1-whine :special-fbinding funcname)))
1652
1653(defnx1 nx1-flet flet (defs &body forms)
1654  (with-nx-declarations (pending)
1655    (let* ((env *nx-lexical-environment*)
1656           (*nx-lexical-environment* env)
1657           (*nx-bound-vars* *nx-bound-vars*)
1658           (new-env (new-lexical-environment env))
1659           (names nil)
1660           (funcs nil)
1661           (pairs nil)
1662           (fname nil)
1663           (name nil))
1664      (multiple-value-bind (body decls) (parse-body forms env nil)
1665        (nx-process-declarations pending decls)
1666        (dolist (def defs (setq names (nreverse names) funcs (nreverse funcs)))
1667          (destructuring-bind (funcname lambda-list &body flet-function-body) def
1668            (setq fname (nx-need-function-name funcname))
1669            (maybe-warn-about-nx1-alphatizer-binding funcname)
1670            (multiple-value-bind (body decls)
1671                                 (parse-body flet-function-body env)
1672              (let ((func (make-afunc))
1673                    (expansion `(lambda ,lambda-list
1674                                  ,@decls
1675                                  (block ,(if (consp funcname) (%cadr funcname) funcname)
1676                                    ,@body))))
1677                (nx-note-source-transformation def expansion)
1678                (setf (afunc-environment func) env
1679                      (afunc-lambdaform func) expansion)
1680                (push func funcs)
1681                (when (and *nx-next-method-var*
1682                             (eq funcname 'call-next-method)
1683                             (null *nx-call-next-method-function*))
1684                    (setq *nx-call-next-method-function* func))             
1685                (push (cons funcname func) pairs)
1686                (if (consp funcname)
1687                  (setq funcname fname))
1688                (push (setq name (make-symbol (symbol-name funcname))) names)
1689                (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env))))))
1690        (let ((vars nil)
1691              (rvars nil)
1692              (rfuncs nil))
1693          (dolist (sym names vars) (push (nx-new-var pending sym) vars))
1694          (nx-effect-other-decls pending new-env)
1695          (setq body (let* ((*nx-lexical-environment* new-env))
1696                       (nx1-dynamic-extent-functions vars new-env)
1697                       (nx1-env-body body env)))
1698          (dolist (pair pairs)
1699            (let ((afunc (cdr pair))
1700                  (var (pop vars)))
1701              (when (or (afunc-callers afunc)
1702                        (neq 0 (afunc-fn-refcount afunc))
1703                        (neq 0 (afunc-fn-downward-refcount afunc)))
1704                (push (nx1-compile-inner-function (%car pair)
1705                                                  (afunc-lambdaform afunc)
1706                                                  afunc
1707                                                  (afunc-environment afunc))
1708                      rfuncs)
1709                (push var rvars))))
1710          (nx-reconcile-inherited-vars rfuncs)
1711          (dolist (f rfuncs) (nx1-afunc-ref f))
1712          (make-acode
1713           (%nx1-operator flet)
1714           rvars
1715           rfuncs
1716           body
1717           *nx-new-p2decls*))))))
1718
1719(defun nx1-dynamic-extent-functions (vars env)
1720  (let ((bits nil)
1721        (varinfo nil))
1722    (dolist (decl (lexenv.fdecls env))
1723      (let ((downward-guy (if (eq (cadr decl) 'dynamic-extent) (car decl))))
1724        (when downward-guy
1725          (multiple-value-bind (finfo afunc) (nx-lexical-finfo downward-guy)
1726            (when (and afunc 
1727                       (not (%ilogbitp $fbitdownward (setq bits (afunc-bits afunc))))
1728                       (setq varinfo (and (consp (%cdr finfo)) (nx-lex-info (%cddr finfo))))
1729                       (memq varinfo vars))
1730              (setf (afunc-bits afunc) 
1731                    (%ilogior 
1732                     bits 
1733                     (%ilsl $fbitdownward 1)
1734                     (%ilsl $fbitbounddownward 1)))
1735              (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo))))))))))
1736         
1737(defnx1 nx1-labels labels (defs &body forms)
1738  (with-nx-declarations (pending)
1739    (let* ((env *nx-lexical-environment*)
1740           (old-env (lexenv.parent-env env))
1741           (*nx-bound-vars* *nx-bound-vars*)
1742           (func nil)
1743           (funcs nil)
1744           (funcrefs nil)
1745           (bodies nil)
1746           (vars nil)
1747           (blockname nil)
1748           (fname nil)
1749           (name nil))
1750      (multiple-value-bind (body decls) (parse-body forms env nil)
1751        (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies)))
1752          (destructuring-bind (funcname lambda-list &body labels-function-body) def
1753            (maybe-warn-about-nx1-alphatizer-binding funcname)
1754            (push (setq func (make-afunc)) funcs)
1755            (setq blockname funcname)
1756            (setq fname (nx-need-function-name funcname))
1757            (when (consp funcname)
1758              (setq blockname (%cadr funcname) funcname fname))
1759            (let ((var (nx-new-var pending (setq name (make-symbol (symbol-name funcname))))))
1760              (nx-set-var-bits var (%ilsl $vbitignoreunused 1))
1761              (push var vars))
1762            (push func funcrefs)
1763            (multiple-value-bind (body decls)
1764                                 (parse-body labels-function-body old-env)
1765              (push (cons funcname (cons 'function (cons func name))) (lexenv.functions env))
1766              (let* ((expansion `(lambda ,lambda-list 
1767                                   ,@decls 
1768                                   (block ,blockname
1769                                     ,@body))))
1770                (nx-note-source-transformation def expansion)
1771                (setf (afunc-lambdaform func) expansion
1772                      (afunc-environment func) env)
1773                (push (cons funcname expansion)
1774                      bodies)))))
1775        (nx1-dynamic-extent-functions vars env)
1776        (dolist (def bodies)
1777          (nx1-compile-inner-function (car def) (cdr def) (setq func (pop funcs))))
1778        (nx-process-declarations pending decls)
1779        (nx-effect-other-decls pending env)
1780        (setq body (nx1-env-body body old-env))
1781        (nx-reconcile-inherited-vars funcrefs)
1782        (dolist (f funcrefs) (nx1-afunc-ref f))
1783        (make-acode
1784         (%nx1-operator labels)
1785         (nreverse vars)
1786         (nreverse funcrefs)
1787         body
1788         *nx-new-p2decls*)))))
1789
1790
1791
1792(defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p))
1793  (unless newval-p (setq newval offset offset 0))
1794  (make-acode
1795   (%nx1-operator %set-bit)
1796   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1797   (nx1-form offset)
1798   (nx1-form newval)))
1799               
1800(defnx1 nx1-set-xxx ((%set-ptr) (%set-long)  (%set-word) (%set-byte)
1801                     (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte))
1802        (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*))
1803  (unless new-val-p (setq newval offset offset 0))
1804  (make-acode
1805   (%nx1-operator %immediate-set-xxx)
1806   (case op
1807     (%set-ptr 0)
1808     (%set-word 2)
1809     (%set-unsigned-word (logior 32 2))
1810     (%set-byte 1)
1811     (%set-unsigned-byte (logior 32 1))
1812     (%set-unsigned-long (logior 32 4))
1813     (t 4))
1814   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1815   (nx1-form offset)
1816   (nx1-form newval)))
1817
1818(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) 
1819        (&whole w ptr offset newval &aux (op *nx-sfname*))
1820  (target-word-size-case
1821   (32 (nx1-treat-as-call w))
1822   (64
1823    (make-acode
1824     (%nx1-operator %immediate-set-xxx)
1825     (case op
1826       (%%set-signed-longlong 8)
1827       (t (logior 32 8)))
1828     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1829     (nx1-form offset)
1830     (nx1-form newval)))))
1831
1832
1833(defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0))
1834  (make-acode
1835   (%nx1-operator typed-form)
1836   'bit
1837   (make-acode
1838    (%nx1-operator %get-bit)
1839    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1840    (nx1-form offset))))
1841
1842(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong))
1843  (&whole w ptrform offsetform)
1844  (target-word-size-case
1845   (32 (nx1-treat-as-call w))
1846   (64
1847    (let* ((flagbits (case *nx-sfname*
1848                       (%%get-unsigned-longlong 8)
1849                       (%%get-signed-longlong (logior 32 8))))
1850           (signed (logbitp 5 flagbits)))
1851      (make-acode (%nx1-operator typed-form)
1852                  (if signed
1853                    '(signed-byte 64)
1854                    '(unsigned-byte 64))
1855                (make-acode 
1856                 (%nx1-operator immediate-get-xxx)
1857                 flagbits
1858                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1859                 (nx1-form offsetform)))))))
1860
1861(defnx1 nx1-get-xxx ((%get-long)  (%get-full-long)  (%get-signed-long)
1862                     (%get-fixnum) 
1863                     (%get-word) (%get-unsigned-word)
1864                     (%get-byte) (%get-unsigned-byte)
1865                     (%get-signed-word) 
1866                     (%get-signed-byte) 
1867                     (%get-unsigned-long))
1868  (ptrform &optional (offset 0))
1869  (let* ((sfname *nx-sfname*)
1870         (flagbits (case sfname
1871                     ((%get-long %get-full-long  %get-signed-long) (logior 4 32))
1872                     (%get-fixnum (logior 4 32 64))
1873                     
1874                     ((%get-word %get-unsigned-word) 2)
1875                     (%get-signed-word (logior 2 32))
1876                     ((%get-byte %get-unsigned-byte) 1)
1877                     (%get-signed-byte (logior 1 32))
1878                     (%get-unsigned-long 4)))
1879         (signed (logbitp 5 flagbits)))
1880    (declare (fixnum flagbits))
1881    (make-acode (%nx1-operator typed-form)
1882                (case (logand 15 flagbits)
1883                  (4 (if (logbitp 6 flagbits)
1884                       'fixnum
1885                       (if signed
1886                         '(signed-byte 32)
1887                         '(unsigned-byte 32))))
1888                  (2 (if signed
1889                       '(signed-byte 16)
1890                       '(unsigned-byte 16)))
1891                  (1 (if signed
1892                       '(signed-byte 8)
1893                       '(unsigned-byte 8))))
1894                (make-acode 
1895                 (%nx1-operator immediate-get-xxx)
1896                 flagbits
1897                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1898                 (nx1-form offset)))))
1899
1900(defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0))
1901  (make-acode
1902   (%nx1-operator %consmacptr%)
1903   (make-acode
1904    (%nx1-operator immediate-get-ptr)
1905    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1906    (nx1-form offset))))
1907
1908(defnx1 nx1-%get-float ((%get-single-float)
1909                        (%get-double-float)) (ptrform &optional (offset 0))
1910  (make-acode
1911   (%nx1-operator typed-form)
1912   (if (eq *nx-sfname* '%get-single-float)
1913     'single-float
1914     'double-float)
1915   (make-acode
1916    (%nx1-default-operator)
1917    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1918    (nx1-form offset))))
1919
1920(defnx1 nx1-%set-float ((%set-single-float)
1921                        (%set-double-float)) (ptrform offset &optional (newval nil newval-p))
1922  (unless newval-p
1923    (setq newval offset
1924          offset 0))
1925    (make-acode
1926     (%nx1-operator typed-form)
1927     (if (eq *nx-sfname* '%set-single-float)
1928       'single-float
1929       'double-float)
1930     (make-acode
1931      (%nx1-default-operator)
1932      (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1933      (nx1-form offset)
1934      (nx1-form newval))))
1935
1936(defnx1 nx1-let let (pairs &body forms &environment old-env)
1937  (collect ((vars)
1938            (vals)
1939            (varbindings))
1940    (with-nx-declarations (pending)
1941      (multiple-value-bind (body decls)
1942                           (parse-body forms *nx-lexical-environment* nil)
1943        (nx-process-declarations pending decls)
1944        ;; Make sure that the initforms are processed in the outer
1945        ;; environment (in case any declaration handlers side-effected
1946        ;; the environment.)
1947       
1948        (let* ((*nx-lexical-environment* old-env))
1949          (dolist (pair pairs)
1950            (let* ((sym (nx-need-var (nx-pair-name pair)))
1951                   (var (nx-cons-var sym))
1952                   (val (nx1-typed-var-initform pending sym (nx-pair-initform pair)))
1953                   (binding (nx1-note-var-binding var val)))
1954              (vars var)
1955              (vals val)
1956              (when binding (varbindings binding)))))
1957        (let* ((*nx-bound-vars* *nx-bound-vars*)
1958               (varbindings (varbindings)))
1959          (dolist (v (vars)) (nx-init-var pending v))
1960          (let* ((form 
1961                  (make-acode 
1962                   (%nx1-operator let)
1963                   (vars)
1964                   (vals)
1965                   (progn
1966                     (nx-effect-other-decls pending *nx-lexical-environment*)
1967                     (nx1-env-body body old-env))
1968                 *nx-new-p2decls*)))
1969          (nx1-check-var-bindings varbindings)
1970          (nx1-punt-bindings (vars) (vals))
1971          form))))))
1972
1973
1974
1975;((lambda (lambda-list) . body) . args)
1976(defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*))
1977  (let* ((old-env body-environment)
1978         (arg-env *nx-lexical-environment*)
1979         (arglist nil)
1980         var-bound-vars
1981         vars vals vars* vals*)
1982    ;; If the lambda list contains &LEXPR, we can't do it.  Yet.
1983    (multiple-value-bind (ok req opttail resttail) (verify-lambda-list lambda-list)
1984      (declare (ignore req opttail))
1985      (when (and ok (eq (%car resttail) '&lexpr))
1986        (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args))))
1987    (let* ((*nx-lexical-environment* body-environment)
1988           (*nx-bound-vars* *nx-bound-vars*))
1989      (with-nx-declarations (pending)
1990        (multiple-value-bind (body decls) (parse-body body *nx-lexical-environment*)
1991          (nx-process-declarations pending decls)
1992          (multiple-value-bind (req opt rest keys auxen)
1993                               (nx-parse-simple-lambda-list pending lambda-list)
1994            (let* ((*nx-lexical-environment* arg-env))
1995              (setq arglist (nx1-formlist args)))
1996            (nx-effect-other-decls pending *nx-lexical-environment*)
1997            (setq body (nx1-env-body body old-env))
1998            (while req
1999              (when (null arglist)
2000                (nx-error "Not enough args ~S for (LAMBDA ~s ...)" args lambda-list))
2001              (let* ((var (pop req))
2002                     (val (pop arglist))
2003                     (binding (nx1-note-var-binding var val)))
2004                (push var vars)
2005                (push val vals)
2006                (when binding (push binding var-bound-vars))))
2007            (nx1-check-var-bindings var-bound-vars)
2008            (nx1-punt-bindings vars vals)
2009            (destructuring-bind (&optional optvars inits spvars) opt
2010              (while optvars
2011                (if arglist
2012                  (progn
2013                    (push (%car optvars) vars) (push (%car arglist) vals)
2014                    (when (%car spvars) (push (%car spvars) vars) (push *nx-t* vals)))
2015                  (progn
2016                    (push (%car optvars) vars*) (push (%car inits) vals*)
2017                    (when (%car spvars) (push (%car spvars) vars*) (push *nx-nil* vals*))))
2018                (setq optvars (%cdr optvars) spvars (%cdr spvars) inits (%cdr inits)
2019                      arglist (%cdr arglist))))
2020            (if arglist
2021              (when (and (not keys) (not rest))
2022                (nx-error "Extra args ~s for (LAMBDA ~s ...)" args lambda-list))
2023              (when rest
2024                (push rest vars*) (push *nx-nil* vals*)
2025                (nx1-punt-bindings (cons rest nil) (cons *nx-nil* nil))
2026                (setq rest nil)))
2027            (when keys
2028              (let* ((punt nil))
2029                (destructuring-bind (kallowother keyvars spvars inits keyvect) keys
2030                  (do* ((pairs arglist (%cddr pairs)))
2031                       ((null pairs))
2032                    (let* ((keyword (car pairs)))
2033                      (when (or (not (acode-p keyword))
2034                                (neq (acode-operator keyword) (%nx1-operator immediate))
2035                                (eq (%cadr keyword) :allow-other-keys))
2036                        (return (setq punt t)))))
2037                  (do* ((nkeys (length keyvect))
2038                        (keyargs (make-array  nkeys :initial-element nil))
2039                        (argl arglist (%cddr argl))
2040                        (n 0 (%i+ n 1))
2041                        idx arg hit)
2042                       ((null argl)
2043                        (unless rest
2044                          (while arglist
2045                            (push (%cadr arglist) vals)
2046                            (setq arglist (%cddr arglist))))
2047                        (dotimes (i (the fixnum nkeys))                     
2048                          (push (%car keyvars) vars*)
2049                          (push (or (%svref keyargs i) (%car inits)) vals*)
2050                          (when (%car spvars)
2051                            (push (%car spvars) vars*)
2052                            (push (if (%svref keyargs i) *nx-t* *nx-nil*) vals*))
2053                          (setq keyvars (%cdr keyvars) inits (%cdr inits) spvars (%cdr spvars)))
2054                        (setq keys hit))
2055                    (setq arg (%car argl))
2056                    (unless (and (not punt)
2057                                 (%cdr argl))
2058                      (let ((var (nx-new-temp-var pending)))
2059                        (when (or (null rest) (%ilogbitp $vbitdynamicextent (nx-var-bits rest)))
2060                          (nx-set-var-bits var (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits var))))
2061                        (setq body (make-acode
2062                                    (%nx1-operator debind)
2063                                    nil
2064                                    (nx-make-lexical-reference var)
2065                                    nil 
2066                                    nil 
2067                                    rest 
2068                                    keys 
2069                                    auxen 
2070                                    nil 
2071                                    body 
2072                                    *nx-new-p2decls* 
2073                                    nil)
2074                              rest var keys nil auxen nil)
2075                        (return nil)))
2076                    (unless (or (setq idx (position (%cadr arg) keyvect))
2077                                (eq (%cadr arg) :allow-other-keys)
2078                                (and kallowother (symbolp (%cadr arg))))
2079                      (nx-error "Invalid keyword ~s in ~s for (LAMBDA ~S ...)"
2080                                (%cadr arg) args lambda-list))
2081                    (when (and idx (null (%svref keyargs idx)))
2082                      (setq hit t)
2083                      (%svset keyargs idx n))))))
2084            (destructuring-bind (&optional auxvars auxvals) auxen
2085              (let ((vars!% (nreconc vars* auxvars))
2086                    (vals!& (nreconc vals* auxvals)))
2087                (make-acode (%nx1-operator lambda-bind)
2088                            (append (nreverse vals) arglist)
2089                            (nreverse vars)
2090                            rest
2091                            keys
2092                            (list vars!% vals!&)
2093                            body
2094                            *nx-new-p2decls*)))))))))
2095
2096(defun nx-inhibit-register-allocation (&optional (why 0))
2097  (let ((afunc *nx-current-function*))
2098    (setf (afunc-bits afunc)
2099          (%ilogior (%ilsl $fbitnoregs 1)
2100                    why
2101                    (afunc-bits afunc)))))
2102
2103
2104
2105(defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body)
2106  (declare (ftype (function (t t t)) %define-ppc-lap-function))
2107  (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap")
2108  (setf (afunc-lfun *nx-current-function*) 
2109        (%define-ppc-lap-function name `((let ,bindings ,@body))
2110                                  (dpb (length bindings) $lfbits-numreq 0))))
2111
2112(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
2113  (declare (ftype (function (t t t)) %define-x86-lap-function))
2114  (require "X86-LAP")
2115  (setf (afunc-lfun *nx-current-function*) 
2116        (%define-x86-lap-function name `((let ,bindings ,@body))
2117                                    (dpb (length bindings) $lfbits-numreq 0))))
2118
2119(defnx1 nx1-arm-lap-function (arm-lap-function) (name bindings &body body)
2120  (declare (ftype (function (t t t)) %define-arm-lap-function))
2121  (require "ARM-LAP")
2122  (setf (afunc-lfun *nx-current-function*)
2123        (%define-arm-lap-function name `((let ,bindings ,@body))
2124                                    (dpb (length bindings) $lfbits-numreq 0))))
2125
2126                   
2127
2128
2129
2130(defun nx1-env-body (body old-env &optional (typecheck (nx-declarations-typecheck *nx-lexical-environment*)))
2131  (do* ((form (nx1-progn-body body))
2132        (typechecks nil)
2133        (env *nx-lexical-environment* (lexenv.parent-env env)))
2134       ((or (eq env old-env) (null env))
2135        (if typechecks
2136          (make-acode
2137           (%nx1-operator progn)
2138           (nconc (nreverse typechecks) (list form)))
2139          form))
2140    (let ((vars (lexenv.variables env)))
2141      (when (consp vars)
2142        (dolist (var vars)
2143          (nx-check-var-usage var)
2144          (when (and typecheck
2145                     (let ((expansion (var-expansion var)))
2146                       (or (atom expansion) (neq (%car expansion) :symbol-macro))))
2147            (let* ((sym (var-name var))
2148                   (type (nx-declared-type sym)))
2149              (unless (eq type t)
2150                (let ((old-bits (nx-var-bits var)))
2151                  (push (nx1-form `(the ,type ,sym)) typechecks)
2152                  (when (%izerop (%ilogand2 old-bits
2153                                            (%ilogior (%ilsl $vbitspecial 1)
2154                                                      (%ilsl $vbitreffed 1)
2155                                                      (%ilsl $vbitclosed 1)
2156                                                      $vrefmask
2157                                                      $vsetqmask)))
2158                    (nx-set-var-bits var (%ilogand2 (nx-var-bits var)
2159                                                    (%ilognot (%ilsl $vbitignore 1))))))))))))))
2160
2161
2162(defnx1 nx1-let* (let*) (varspecs &body forms)
2163  (let* ((vars nil)
2164         (vals nil)
2165         (val nil)
2166         (var-bound-vars nil)
2167         (*nx-bound-vars* *nx-bound-vars*)
2168         (old-env *nx-lexical-environment*))
2169    (with-nx-declarations (pending)
2170      (multiple-value-bind (body decls)
2171                           (parse-body forms *nx-lexical-environment* nil)
2172        (nx-process-declarations pending decls)
2173        (dolist (pair varspecs)         
2174          (let* ((sym (nx-need-var (nx-pair-name pair)))
2175                 (var (progn 
2176                        (push (setq val (nx1-typed-var-initform pending sym (nx-pair-initform pair))) vals)
2177                        (nx-new-var pending sym)))
2178                 (binding (nx1-note-var-binding var val)))
2179            (when binding (push binding var-bound-vars))
2180            (push var vars)))
2181        (nx-effect-other-decls pending *nx-lexical-environment*)
2182        (let* ((result
2183                (make-acode 
2184                 (%nx1-default-operator)
2185                 (setq vars (nreverse vars))
2186                 (setq vals (nreverse vals))
2187                 (nx1-env-body body old-env)
2188                 *nx-new-p2decls*)))
2189          (nx1-check-var-bindings var-bound-vars)
2190          (nx1-punt-bindings vars vals)
2191          result)))))
2192
2193(defnx1 nx1-multiple-value-bind multiple-value-bind 
2194        (varspecs bindform &body forms)
2195  (if (= (length varspecs) 1)
2196    (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms))
2197    (let* ((vars nil)
2198           (*nx-bound-vars* *nx-bound-vars*)
2199           (old-env *nx-lexical-environment*)
2200           (mvform (nx1-form bindform)))
2201      (with-nx-declarations (pending)
2202        (multiple-value-bind (body decls)
2203                             (parse-body forms *nx-lexical-environment* nil)
2204          (nx-process-declarations pending decls)
2205          (dolist (sym varspecs)
2206            (push (nx-new-var pending sym t) vars))
2207          (nx-effect-other-decls pending *nx-lexical-environment*)
2208          (make-acode
2209           (%nx1-operator multiple-value-bind)
2210           (nreverse vars)
2211           mvform
2212           (nx1-env-body body old-env)
2213           *nx-new-p2decls*))))))
2214
2215
2216;;; This isn't intended to be user-visible; there isn't a whole lot of
2217;;; sanity-checking applied to the subtag.
2218(defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p))
2219  (if init-p                            ; ensure that "init" is evaluated before miscobj is created.
2220    (make-acode (%nx1-operator %make-uvector)
2221                (nx1-form element-count)
2222                (nx1-form subtag)
2223                (nx1-form init))
2224    (make-acode (%nx1-operator %make-uvector)
2225                (nx1-form element-count)
2226                (nx1-form subtag))))
2227
2228(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset)
2229  (make-acode (%nx1-operator %lisp-word-ref)
2230              (nx1-form base)
2231              (nx1-form offset)))
2232
2233(defnx1 nx1-%single-to-double ((%single-to-double)) (arg)
2234  (make-acode (%nx1-operator %single-to-double)
2235              (nx1-form arg)))
2236
2237(defnx1 nx1-%double-to-single ((%double-to-single)) (arg)
2238  (make-acode (%nx1-operator %double-to-single)
2239              (nx1-form arg)))
2240
2241(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg)
2242  (make-acode (%nx1-operator %fixnum-to-double)
2243              (nx1-form arg)))
2244
2245(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg)
2246  (make-acode (%nx1-operator %fixnum-to-single)
2247              (nx1-form arg)))
2248
2249(defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p))
2250  (declare (ignore result))
2251  (if result-p
2252    (nx1-treat-as-call whole)
2253    (make-acode (%nx1-operator %double-float) (nx1-form arg))))
2254
2255(defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p))
2256  (declare (ignore result))       
2257  (if result-p
2258    (nx1-treat-as-call whole)
2259    (make-acode (%nx1-operator %single-float) (nx1-form arg))))
2260
2261
2262(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg)
2263  (make-acode (%nx1-default-operator) (nx1-form arg)))
2264
2265(defnx1 nx1-%ilognot (%ilognot) (n)
2266  ;; Bootstrapping nonsense.
2267  (if (aref (backend-p2-dispatch *target-backend*)
2268            (logand operator-id-mask (%nx1-operator %ilognot)))
2269    (make-acode (%nx1-operator typed-form)
2270                'fixnum
2271                (make-acode (%nx1-operator %ilognot)
2272                            (nx1-form n)))
2273    (nx1-form (macroexpand `(%ilognot ,n)))))
2274
2275   
2276(defnx1 nx1-ash (ash) (&whole call &environment env num amt)
2277  (flet ((defer-to-backend ()
2278             ;; Bootstrapping nonsense
2279             (if (svref (backend-p2-dispatch *target-backend*)
2280                        (logand operator-id-mask (%nx1-operator ash)))
2281               (make-acode (%nx1-operator typed-form)
2282                           'integer
2283                           (make-acode
2284                            (%nx1-operator ash)
2285                            (nx1-form num)
2286                            (nx1-form amt)))
2287               (nx1-treat-as-call call))))
2288    (let* ((unsigned-natural-type *nx-target-natural-type*) 
2289           (max (target-word-size-case (32 32) (64 64)))
2290           (maxbits (target-word-size-case
2291                     (32 29)
2292                     (64 60))))
2293      (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
2294            ((and (fixnump amt)
2295                  (< amt 0))
2296             (if (nx-form-typep num 'fixnum env)
2297               (make-acode (%nx1-operator %iasr)
2298                           (make-acode (%nx1-operator fixnum)
2299                                       (- amt))
2300                           (nx1-form num))
2301               (if (nx-form-typep num unsigned-natural-type env)
2302                 (if (< (- amt) max)
2303                   (make-acode (%nx1-operator natural-shift-right)
2304                               (nx1-form num)
2305                               (make-acode (%nx1-operator fixnum)
2306                                           (- amt)))
2307                   (nx1-form `(progn (require-type ,num 'integer) 0) env))
2308                 (defer-to-backend))))
2309            ((and (fixnump amt)
2310                  (<= 0 amt maxbits)
2311                  (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env)
2312                      (and (nx-form-typep num 'fixnum env)
2313                           (nx-trust-declarations env)
2314                           (subtypep *nx-form-type* 'fixnum))))
2315             (nx1-form `(%ilsl ,amt ,num)))
2316            ((and (fixnump amt)
2317                  (< 0 amt max)
2318                  (nx-form-typep num unsigned-natural-type env)
2319                  (nx-trust-declarations env)
2320                  (subtypep *nx-form-type* unsigned-natural-type))
2321             (make-acode (%nx1-operator natural-shift-left)
2322                         (nx1-form num)
2323                         (nx1-form amt)))
2324            ((fixnump num)
2325             (let* ((field-width (1+ (integer-length num)))
2326                    ;; num fits in a `(signed-byte ,field-width)
2327                    (max-shift (- (1+ maxbits) field-width)))
2328               (if (nx-form-typep amt `(mod ,(1+ max-shift)) env)
2329                 (nx1-form `(%ilsl ,amt ,num))
2330                 (defer-to-backend))))
2331            (t (defer-to-backend))))))
2332
2333   
2334       
2335(defun nx-badformat (&rest args)
2336 (nx-error "Bad argument format in ~S ." args))
2337
2338(defnx1 nx1-eval-when eval-when (when &body body)
2339  (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body)))
2340
2341(defnx1 nx1-misplaced (declare) (&rest args)
2342  (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
2343
Note: See TracBrowser for help on using the repository browser.