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

Last change on this file since 13332 was 13332, checked in by gz, 10 years ago

Improved compilation for some fixnum operations, %svref (r13247-r13253 from trunk)

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