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

Last change on this file since 11373 was 11373, checked in by gz, 12 years ago

Finish source location and pc -> source mapping support, from working-0711 but with some modifications.

Details:

Source location are recorded in CCL:SOURCE-NOTE's, which are objects with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end positions are file positions (not character positions). The text will be NIL unless text recording was on at read-time. If the original file is still available, you can force missing source text to be read from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.

Source-note's are associated with definitions (via record-source-file) and also stored in function objects (including anonymous and nested functions). The former can be retrieved via CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.

The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-LOCATIONS*:

If NIL, don't store source-notes in function objects, and store only the filename for definitions (the latter only if *record-source-file* is true).
If T, store source-notes, including a copy of the original source text, for function objects and definitions (the latter only if *record-source-file* is true).
If :NO-TEXT, store source-notes, but without saved text, for function objects and defintions (the latter only if *record-source-file* is true). This is the default.

PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a compressed table mapping pc offsets to corresponding source locations. This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the source at offset pc in the function.

Currently the only thing that makes use of any of this is the disassembler. ILISP and current version of Slime still use backward-compatible functions that deal with filenames only. The plan is to make Slime, and our IDE, use this eventually.

Known bug: most of this only works through the file compiler. Still need to make it work with loading from source (not hard, just haven't gotten to it yet).

This checkin incidentally includes bits and pieces of support for code coverage, which is still
incomplete and untested. Ignore it.

The PPC version is untested. I need to check it in so I can move to a PPC for testing.

Sizes:

18387152 Nov 16 10:00 lx86cl64.image-no-loc-no-pc
19296464 Nov 16 10:11 lx86cl64.image-loc-no-text-no-pc
20517072 Nov 16 09:58 lx86cl64.image-loc-no-text-with-pc [default]
25514192 Nov 16 09:55 lx86cl64.image-loc-with-text-with-pc

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