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

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

Revert to previous versions (these files were checked in accidentally
in r15306.)

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