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

Last change on this file since 13070 was 13070, checked in by gz, 11 years ago

r13066, r13067 from trunk: copyrights etc

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