source: branches/rme-logops/compiler/nx1.lisp @ 15706

Last change on this file since 15706 was 13885, checked in by rme, 9 years ago

purported improvements to logior on natural-sized operands

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