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

Last change on this file since 16604 was 16604, checked in by gb, 6 years ago

in NX1-LAMBDA-BIND, don't just try to compile again. A simple beginner's mistake, but that
leads to unbounded recursion.

in x862-LAMBDA-BIND: bail out in new backend.

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