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

Last change on this file since 8421 was 8421, checked in by wws, 13 years ago

Marco's source-tracking-0801 branch passes tests on the customer system. Merge it here.

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