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

Last change on this file since 15306 was 15306, checked in by gb, 8 years ago

DEFINE-CONDITION arranges to validate parent types as subtypes of CONDITION.
Move some condition-types around to allow this to be bootstrapped.
Fixes ticket:928.

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