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

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

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

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