source: trunk/source/compiler/nx0.lisp @ 14406

Last change on this file since 14406 was 14406, checked in by gb, 10 years ago

Start to bootstrap a change which uses "normal" acode operators to represent
T and NIL, rather than semi-magic tokens *NX-T* and *NX-NIL*. (We want to
do displacing/destructive operations on acode forms, even those representing
T and NIL.) This will require more bootstrapping and new images soon.

In the x86 backend, don't "punt" variables in X862-SEQ-BIND if they're already
"punted". ("Punting" a variable that's bound to a simple expression and never
SETQed involves effectively replacing all references to it with references to
that simple expression.) Variable replacement/punting may happen in an earlier
pass, Real Soon Now.

Change the trunk's minor version number to 7, e.g., this is now 1.7-dev.

New images soon.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 117.7 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19
20(in-package "CCL")
21
22;; :compiler:nx0.lisp - part of the compiler
23
24
25(defstruct pending-declarations
26  vdecls
27  fdecls
28  mdecls)
29
30; Phony AFUNC "defstruct":
31(defun make-afunc (&aux (v (%make-afunc)))
32  (setf (afunc-fn-refcount v) 0)
33  (setf (afunc-fn-downward-refcount v) 0)
34  (setf (afunc-bits v) 0)
35  v)
36
37(defvar *compile-code-coverage* nil "True to instrument for code coverage")
38
39
40
41
42(defvar *nx-blocks* nil)
43(defvar *nx-tags* nil)
44(defvar *nx-parent-function* nil)
45(defvar *nx-current-function* nil)
46(defvar *nx-lexical-environment* nil)
47(defvar *nx-symbol-macros* nil)
48(defvar *nx-inner-functions* nil)
49(defvar *nx-cur-func-name* nil)
50(defvar *nx-current-note* nil)
51(defvar *nx-source-note-map* nil) ;; there might be external refs, from macros.
52(defvar *nx-form-type* t)
53;(defvar *nx-proclaimed-inline* nil)
54;(defvar *nx-proclaimed-inline* (make-hash-table :size 400 :test #'eq))
55(defvar *nx-proclaimed-ignore* nil)
56(defvar *nx-parsing-lambda-decls* nil) ; el grosso.
57(defparameter *nx-standard-declaration-handlers* nil)
58(defparameter *nx-hoist-declarations* t)
59(defparameter *nx-loop-nesting-level* 0)
60(defvar *nx-break-on-program-errors* t)
61
62(defvar *nx1-vcells* nil)
63(defvar *nx1-fcells* nil)
64
65(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
66
67(defvar *nx-lambdalist* (make-symbol "lambdalist"))
68(defvar *nx-nil* (make-acode (%nx1-operator nil)))
69(defvar *nx-t* (make-acode (%nx1-operator t)))
70
71(defun %nx-null (x)
72  (or (eq x *nx-nil*)
73      (if (acode-p x)
74        (eql (acode-operator x)
75             (%nx1-operator nil)))))
76
77(defun %nx-t (x)
78  (or (eq x *nx-t*)
79      (if (acode-p x)
80        (eql (acode-operator x)
81             (%nx1-operator t)))))
82
83(defparameter *nx-current-compiler-policy* (%default-compiler-policy))
84
85(defvar *nx-next-method-var* nil)
86(defvar *nx-call-next-method-function* nil)
87
88(defvar *nx-sfname* nil)
89(defvar *nx-operators* ())
90(defvar *nx-warnings* nil)
91
92(defvar *nx1-compiler-special-forms* nil "Real special forms")
93
94(defmacro without-compiling-code-coverage (&body body)
95  "Disable code coverage in the lexical scope of the form"
96  `(compiler-let ((*nx-current-code-note* nil))
97     ,@body))
98
99(defparameter *nx-never-tail-call*
100  '(error cerror break warn type-error file-error
101    signal-program-error signal-simple-program-error
102    print-call-history
103    #-bccl %get-frame-pointer
104    #-bccl break-loop)
105  "List of functions which never return multiple values and
106   should never be tail-called.")
107
108(defvar *cross-compiling* nil "bootstrapping")
109
110
111(defparameter *nx-operator-result-types*
112  '((#.(%nx1-operator list) . list)
113    (#.(%nx1-operator memq) . list)
114    (#.(%nx1-operator %temp-list) . list)
115    (#.(%nx1-operator assq) . list)
116    (#.(%nx1-operator cons) . cons)
117    (#.(%nx1-operator rplaca) . cons)
118    (#.(%nx1-operator %rplaca) . cons)
119    (#.(%nx1-operator rplacd) . cons)
120    (#.(%nx1-operator %rplacd) . cons)
121    (#.(%nx1-operator %temp-cons) . cons)
122    (#.(%nx1-operator %i+) . fixnum)
123    (#.(%nx1-operator %i-) . fixnum)
124    (#.(%nx1-operator %i*) . fixnum)
125    (#.(%nx1-operator %ilsl) . fixnum)
126    (#.(%nx1-operator %ilsr) . fixnum)
127    (#.(%nx1-operator %iasr) . fixnum)
128    (#.(%nx1-operator %ilogior2) . fixnum)
129    (#.(%nx1-operator %ilogand2) . fixnum)
130    (#.(%nx1-operator %ilogxor2) . fixnum)
131    (#.(%nx1-operator %code-char) . character)
132    (#.(%nx1-operator schar) . character)
133    (#.(%nx1-operator length) . fixnum)
134    (#.(%nx1-operator uvsize) . fixnum)
135    (#.(%nx1-operator %double-float/-2) . double-float)
136    (#.(%nx1-operator %double-float/-2!) . double-float) ; no such operator
137    (#.(%nx1-operator %double-float+-2) . double-float)
138    (#.(%nx1-operator %double-float+-2!) . double-float)
139    (#.(%nx1-operator %double-float--2) . double-float)
140    (#.(%nx1-operator %double-float--2!) . double-float)
141    (#.(%nx1-operator %double-float*-2) . double-float)
142    (#.(%nx1-operator %double-float*-2!) . double-float)
143    (#.(%nx1-operator %short-float/-2) . double-float)
144    (#.(%nx1-operator %short-float+-2) . double-float)
145    (#.(%nx1-operator %short-float--2) . double-float)
146    (#.(%nx1-operator %short-float*-2) . double-float)
147    (#.(%nx1-operator %double-to-single) . single-float)
148    (#.(%nx1-operator %single-to-double) . double-float)
149    (#.(%nx1-operator %fixnum-to-single) . single-float)
150    (#.(%nx1-operator %fixnum-to-double) . double-float)
151    (#.(%nx1-operator char-code) . #.`(integer 0 (,char-code-limit)))
152   ))
153
154(defparameter *nx-operator-result-types-by-name*
155  '((%ilognot . fixnum)
156    (%ilogxor . fixnum)
157    (%ilogand . fixnum)
158    (%ilogior . fixnum)
159    (char-code . #. `(integer 0 (,char-code-limit)))))
160
161(setq *nx-known-declarations*
162  '(special inline notinline type ftype function ignore optimize dynamic-extent ignorable
163    ignore-if-unused settable unsettable
164     notspecial global-function-name debugging-function-name resident))
165
166(defun find-optimize-quantity (name env)
167  (let ((pair ()))
168    (loop
169      (when (listp env) (return))
170      (when (setq pair (assq name (lexenv.mdecls env)))
171        (return (%cdr pair)))
172      (setq env (lexenv.parent-env env)))))
173   
174(defun debug-optimize-quantity (env)
175  (or (find-optimize-quantity 'debug env)
176      *nx-debug*))
177
178(defun space-optimize-quantity (env)
179  (or (find-optimize-quantity 'space env)
180      *nx-space*))
181
182(defun safety-optimize-quantity (env)
183  (or (find-optimize-quantity 'safety env)
184      *nx-safety*))
185
186(defun speed-optimize-quantity (env)
187  (or (find-optimize-quantity 'speed env)
188      *nx-speed*))
189
190(defun compilation-speed-optimize-quantity (env)
191  (or (find-optimize-quantity 'compilation-speed env)
192      *nx-cspeed*))
193
194(defvar *nx-ignore-if-unused* ())
195(defvar *nx-new-p2decls* ())
196(defvar *nx-inlined-self* t)
197(defvar *nx-all-vars* nil)
198(defvar *nx-bound-vars* nil)
199(defvar *nx-punted-vars* nil)
200(defvar *nx-inline-expansions* nil)
201(defparameter *nx-compile-time-compiler-macros* nil)
202(defvar *nx-global-function-name* nil)
203(defvar *nx-can-constant-fold* ())
204(defvar *nx-synonyms* ())
205(defvar *nx-load-time-eval-token* ())
206
207(define-condition compiler-function-overflow (condition) ())
208
209(defun compiler-function-overflow ()
210  (signal 'compiler-function-overflow)
211  (error "Function size exceeds compiler limitation."))
212
213(defvar *compiler-macros* (make-hash-table :size 100 :test #'eq))
214
215;;; Just who was responsible for the "FUNCALL" nonsense ?
216;;; Whoever it is deserves a slow and painful death ...
217
218(defmacro define-compiler-macro  (name arglist &body body &environment env)
219  "Define a compiler-macro for NAME."
220  (let* ((block-name name)
221         (def-name (validate-function-name name)))
222    (unless (eq def-name block-name)
223      (setq block-name (cadr block-name)))
224    (let ((body (parse-macro-1 block-name arglist body env)))
225      `(eval-when (:compile-toplevel :load-toplevel :execute)
226         (eval-when (:load-toplevel :execute)
227           (record-source-file ',name 'compiler-macro))
228         (setf (compiler-macro-function ',name)
229               (nfunction (compiler-macro-function ,name)  ,body))
230         ',name))))
231
232;;; This is silly (as may be the whole idea of actually -using-
233;;; compiler-macros).  Compiler-macroexpand-1 will return a second
234;;; value of NIL if the value returned by the expansion function is EQ
235;;; to the original form.  This differs from the behavior of
236;;; macroexpand-1, but users are not encouraged to write macros which
237;;; return their &whole args (as the DEFINE-COMPILER-MACRO issue
238;;; encourages them to do ...)  Cheer up! Neither of these things have
239;;; to exist!
240(defun compiler-macroexpand-1 (form &optional env)
241  (let ((expander nil)
242        (newdef nil))
243    (if (and (consp form)
244             (symbolp (car form))
245             (setq expander (compiler-macro-function (car form) env)))
246      (values (setq newdef (funcall *macroexpand-hook* expander form env)) (neq newdef form))
247      (values form nil))))
248
249; ... If this exists, it should probably be exported.
250(defun compiler-macroexpand (form &optional env)
251  (multiple-value-bind (new win) (compiler-macroexpand-1 form env)
252    (do* ((won-at-least-once win))
253         ((null win) (values new won-at-least-once))
254      (multiple-value-setq (new win) (compiler-macroexpand-1 new env)))))
255
256
257
258
259(defun compiler-macro-function (name &optional env)
260  "If NAME names a compiler-macro in ENV, return the expansion function, else
261   return NIL. Can be set with SETF when ENV is NIL."
262  (setq name (validate-function-name name))
263  (unless (nx-lexical-finfo name env)
264    (or (cdr (assq name *nx-compile-time-compiler-macros*))
265        (values (gethash name *compiler-macros*)))))
266
267(defun set-compiler-macro-function (name def)
268  (setq name (validate-function-name name))
269  (if def
270    (setf (gethash name *compiler-macros*) def)
271    (remhash name *compiler-macros*))
272  def)
273
274(defsetf compiler-macro-function set-compiler-macro-function)
275
276(defparameter *nx-add-xref-entry-hook* nil
277  "When non-NIL, assumed to be a function of 3 arguments
278which asserts that the specied relation from the current
279function to the indicated name is true.")
280
281;; Cross-referencing
282(defun nx-record-xref-info (relation name)
283  (let* ((axe (fboundp '%add-xref-entry)))
284    (when axe
285      (funcall axe relation *nx-cur-func-name* name))))
286
287
288
289(defun nx-apply-env-hook (hook env &rest args)
290  (declare (dynamic-extent args))
291  (when (fixnump hook) (setq hook (uvref *nx-current-compiler-policy* hook)))
292  (if hook
293    (if (functionp hook)
294      (apply hook env args)
295      t)))
296
297(defun nx-self-calls-inlineable (env)
298  (nx-apply-env-hook policy.inline-self-calls env))
299
300(defun nx-allow-register-allocation (env)
301  (not (nx-apply-env-hook policy.inhibit-register-allocation env)))
302
303(defun nx-trust-declarations (env)
304  (unless (eq (safety-optimize-quantity env) 3)
305    (nx-apply-env-hook policy.trust-declarations env)))
306
307(defun nx-open-code-in-line (env)
308  (nx-apply-env-hook policy.open-code-inline env))
309
310(defun nx-inline-car-cdr (env)
311  (unless (eq (safety-optimize-quantity env) 3)
312    (nx-apply-env-hook policy.inhibit-safety-checking env)))
313
314(defun nx-inhibit-safety-checking (env)
315  (unless (eq (safety-optimize-quantity env) 3)
316    (nx-apply-env-hook policy.inhibit-safety-checking env)))
317
318(defun nx-tailcalls (env)
319  (nx-apply-env-hook policy.allow-tail-recursion-elimination env))
320
321(defun nx-allow-transforms (env)
322  (nx-apply-env-hook policy.allow-transforms env))
323
324(defun nx-force-boundp-checks (var env)
325  (or (eq (safety-optimize-quantity env) 3)
326      (nx-apply-env-hook policy.force-boundp-checks var env)))
327
328(defun nx-substititute-constant-value (symbol value env)
329  (nx-apply-env-hook policy.allow-constant-substitution symbol value env))
330
331(defun nx-declarations-typecheck (env)
332  (nx-apply-env-hook policy.declarations-typecheck env))
333
334
335#-bccl
336(defun nx1-default-operator ()
337 (or (gethash *nx-sfname* *nx1-operators*)
338     (error "Bug - operator not found for  ~S" *nx-sfname*)))
339
340(defun nx-new-temp-var (pending &optional (pname "COMPILER-VAR"))
341  (let ((var (nx-new-var pending (make-symbol pname))))
342    (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
343                                   (%ilsl $vbittemporary 1)
344                                   (nx-var-bits var)))
345    var))
346
347(defun nx-new-vdecl (pending name class &optional info)
348  (push (cons name (cons class info)) (pending-declarations-vdecls pending)))
349
350(defun nx-new-fdecl (pending name class &optional info)
351  (push (cons name (cons class info)) (pending-declarations-fdecls pending)))
352
353(defun nx-new-var (pending sym &optional (check t))
354  (nx-init-var pending (nx-cons-var (nx-need-var sym check) 0)))
355                   
356(defun nx-proclaimed-special-p (sym)
357  (setq sym (nx-need-sym sym))
358  (let* ((defenv (definition-environment *nx-lexical-environment*))
359         (specials (if defenv (defenv.specials defenv))))
360    (or (assq sym specials)
361        (proclaimed-special-p sym))))
362
363(defun nx-proclaimed-parameter-p (sym)
364  (setq sym (nx-need-sym sym))
365  (or (constantp sym)
366      (multiple-value-bind (special-p info) (nx-lex-info sym t)
367        (or 
368         (and (eq special-p :special) info)
369         (let* ((defenv (definition-environment *nx-lexical-environment*)))
370           (if defenv 
371             (or (%cdr (assq sym (defenv.specials defenv)))
372                 (assq sym (defenv.constants defenv)))))))))
373
374(defun nx-process-declarations (pending decls &optional (env *nx-lexical-environment*) &aux s f)
375  (dolist (decl decls pending)
376    (dolist (spec (%cdr decl))
377      (if (memq (setq s (car spec)) *nx-known-declarations*)
378        (if (setq f (getf *nx-standard-declaration-handlers* s))
379          (funcall f pending spec env))
380        ; Any type name is now (ANSI CL) a valid declaration.
381        (if (specifier-type-if-known s env)
382          (nx-process-type-decl pending spec s (%cdr spec) env)
383          (nx-bad-decls spec))))))
384
385; Put all variable decls for the symbol VAR into effect in environment ENV.  Now.
386; Returns list of all new vdecls pertaining to VAR.
387(defun nx-effect-vdecls (pending var env)
388  (let ((vdecls (lexenv.vdecls env))
389        (own nil))
390    (dolist (decl (pending-declarations-vdecls pending) (setf (lexenv.vdecls env) vdecls))
391      (when (eq (car decl) var) 
392        (when (eq (cadr decl) 'type)
393          (let* ((newtype (cddr decl))
394                 (merged-type (nx1-type-intersect var newtype (nx-declared-type var env))))
395             (unless (eq merged-type newtype)
396              (rplacd (cdr decl) merged-type))))
397        (push decl vdecls)
398        (push (cdr decl) own)))
399    own))
400
401
402(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*))
403  (let* ((type t)
404         (*nx-form-type* (if (nx-trust-declarations env)
405                           (dolist (decl (pending-declarations-vdecls pending) type)
406                             (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
407                               (setq type (nx1-type-intersect sym (nx-target-type type) (cddr decl)))))
408                           t)))
409    (nx1-typed-form form env)))
410
411; Guess.
412(defun nx-effect-fdecls (pending var env)
413  (let ((fdecls (lexenv.fdecls env))
414        (own nil))
415    (dolist (decl (pending-declarations-fdecls pending) (setf (lexenv.fdecls env) fdecls))
416      (when (eq (car decl) var) 
417        (push decl fdecls)
418        (push (cdr decl) own)))
419    own))
420
421
422
423
424(defun nx-acode-form-typep (form type env)
425  (acode-form-typep form type  (nx-trust-declarations env)))
426
427(defun acode-form-typep (form type trust-decls)
428  (if (acode-p form)
429    (let* ((op (acode-operator form))
430           (opval-p (or (eq op (%nx1-operator fixnum)) (eq op (%nx1-operator immediate))))
431           (optype (acode-form-type form trust-decls)))
432      (values
433       (if optype 
434         (subtypep optype (nx-target-type type))
435         (if opval-p (typep (%cadr form) (nx-target-type type))))))))
436
437(defun nx-acode-form-type (form env)
438  (acode-form-type form (nx-trust-declarations env)))
439
440(defparameter *numeric-acode-ops*
441  (list (%nx1-operator add2)
442        (%nx1-operator sub2)
443        (%nx1-operator mul2)))
444
445
446
447(defun acode-form-type (form trust-decls &optional (assert t))
448  (let* ((typespec
449          (if (nx-null form)
450            'null
451            (if (eq form *nx-t*)
452              'boolean
453              (nx-target-type 
454               (if (acode-p form)
455                 (let* ((op (acode-operator form)))
456                   (if (eq op (%nx1-operator fixnum))
457                     (let* ((val (cadr form)))
458                       `(integer ,val ,val))
459                     (if (eq op (%nx1-operator immediate))
460                       (type-of (%cadr form))
461                       (and trust-decls
462                            (if (eq op (%nx1-operator type-asserted-form))
463                              (progn
464                                (setq assert nil)
465                                (%cadr form))
466                              (if (eq op (%nx1-operator typed-form))
467                                (destructuring-bind (type subform &optional check) (%cdr form)                                 
468                                  (when (and assert (null check))
469                                    (setf (%car form) (%nx1-operator type-asserted-form)
470                                          (%cadr form)
471                                          (type-specifier
472                                           (specifier-type `(and ,type ,(acode-form-type subform trust-decls assert))))
473                                          assert nil))
474                                  (%cadr form))
475                                (if (eq op (%nx1-operator lexical-reference))
476                                  (locally (declare (special *nx-in-frontend*))
477                                    (unless *nx-in-frontend*
478                                      (let* ((var (cadr form))
479                                             (bits (nx-var-bits var))
480                                             (punted (logbitp $vbitpunted bits)))
481                                        (if (or punted
482                                                (eql 0 (%ilogand $vsetqmask bits)))
483                                          (var-inittype var)))))
484                                  (if (or (eq op (%nx1-operator %aref1))
485                                          (eq op (%nx1-operator simple-typed-aref2))
486                                          (eq op (%nx1-operator general-aref2))
487                                          (eq op (%nx1-operator simple-typed-aref3))
488                                          (eq op (%nx1-operator general-aref3)))
489                                    (let* ((atype (acode-form-type (cadr form) t))
490                                           (actype (if atype (specifier-type atype))))
491                                      (if (typep actype 'array-ctype)
492                                        (type-specifier (array-ctype-specialized-element-type
493                                                         actype))))
494                                    (if (member op *numeric-acode-ops*)
495                                      (multiple-value-bind (f1 f2)
496                                          (nx-binop-numeric-contagion (cadr form)
497                                                                      (caddr form)
498                                                                      trust-decls)
499                                        (if (and (acode-form-typep f1 'real trust-decls)
500                                                 (acode-form-typep f2 'real trust-decls))
501
502                                          (if (or (acode-form-typep f1 'double-float trust-decls)
503                                                  (acode-form-typep f2 'double-float trust-decls))
504                                            'double-float
505                                            (if (or (acode-form-typep f1 'single-float trust-decls)
506                                                    (acode-form-typep f2 'single-float trust-decls))
507                                              'single-float
508                                              'float))))
509                                      (cdr (assq op *nx-operator-result-types*)))))))))))))))))
510    (if (or (null typespec) (eq typespec '*)) (setq typespec t))
511    (when (and (acode-p form) (typep (acode-operator form) 'fixnum) assert)
512      (let* ((new (cons typespec (cons (cons (%car form) (%cdr form)) nil))))
513        (setf (%car form) (%nx1-operator type-asserted-form)
514              (%cdr form) new)))
515    typespec))
516
517(defun nx-binop-numeric-contagion (form1 form2 trust-decls)
518  (cond ((acode-form-typep form1 'double-float trust-decls)
519         (if (acode-form-typep form2 'double-float trust-decls)
520           (values form1 form2)
521           (let* ((c2 (acode-real-constant-p form2)))
522             (if c2
523               (values form1 (make-acode (%nx1-operator immediate)
524                                         (float c2 0.0d0)))
525               (if (acode-form-typep form2 'fixnum trust-decls)
526                 (values form1 (make-acode (%nx1-operator %fixnum-to-double)
527                                           form2))
528                 (values form1 form2))))))
529        ((acode-form-typep form2 'double-float trust-decls)
530         (let* ((c1 (acode-real-constant-p form1)))
531           (if c1
532             (values (make-acode (%nx1-operator immediate)
533                                 (float c1 0.0d0)) form2)
534             (if (acode-form-typep form1 'fixnum trust-decls)
535               (values (make-acode (%nx1-operator %fixnum-to-double)
536                                   form1) form2)
537               (values form1 form2)))))
538        ((acode-form-typep form1 'single-float trust-decls)
539         (if (acode-form-typep form2 'single-float trust-decls)
540           (values form1 form2)
541           (let* ((c2 (acode-real-constant-p form2)))
542             (if c2
543               (values form1 (make-acode (%nx1-operator immediate)
544                                         (float c2 0.0f0)))
545               (if (acode-form-typep form2 'fixnum trust-decls)
546                 (values form1 (make-acode (%nx1-operator %fixnum-to-single)
547                                           form2))
548                 (values form1 form2))))))
549        ((acode-form-typep form2 'single-float trust-decls)
550         (let* ((c1 (acode-real-constant-p form1)))
551           (if c1
552             (values (make-acode (%nx1-operator immediate)
553                                 (float c1 0.0f0)) form2)
554             (if (acode-form-typep form1 'fixnum trust-decls)
555               (values (make-acode (%nx1-operator %fixnum-to-single)
556                                   form1) form2)
557               (values form1 form2)))))
558        (t
559         (values form1 form2))))
560
561(defun acode-punted-var-p (var)
562  (let ((bits (nx-var-bits var)))
563    (and (%ilogbitp $vbitpunted bits)
564         (not (%ilogbitp $vbitspecial bits)))))
565
566;; Use acode-unwrapped-form-value to reason about the value of a form at
567;; compile time.   To actually generate code, use acode-unwrapped-form.
568(defun acode-unwrapped-form-value (form)
569  ;; Currently no difference, but if had any operators like with-code-note,
570  ;; would unwrap them here.
571  (acode-unwrapped-form form))
572
573; Strip off any type info or "punted" lexical references.
574; ??? Is it true that the "value" of the punted reference is unwrapped ? ???
575(defun acode-unwrapped-form (form) 
576  (while (and (consp (setq form (nx-untyped-form form)))
577           (eq (%car form) (%nx1-operator lexical-reference))
578           (acode-punted-var-p (cadr form)))
579    (setq form (var-ea (cadr form))))
580  form)
581
582(defun acode-fixnum-form-p (x)
583  (setq x (acode-unwrapped-form-value x))
584  (if (acode-p x)
585    (if (eq (acode-operator x) (%nx1-operator fixnum)) 
586      (cadr x))))
587
588(defun acode-xxx-form-p (x fixnum-supertype)
589  (or (acode-fixnum-form-p x)
590      (progn
591        (setq x (acode-unwrapped-form-value x))
592        (if (acode-p x)
593          (if (and (eq (acode-operator x) (%nx1-operator immediate))
594                   (typep (cadr x) fixnum-supertype))
595            (cadr x))))))
596
597(defun acode-integer-form-p (x)
598  (acode-xxx-form-p x 'integer))
599
600(defun acode-integer-constant-p (x bits)
601  (let ((int (acode-integer-form-p x)))
602    (and int
603         (or
604           (typep int `(signed-byte ,bits))
605           (typep int `(unsigned-byte ,bits)))
606         int)))
607
608(defun acode-real-constant-p (x)
609  (acode-xxx-form-p x 'real))
610
611(defun nx-lookup-target-uvector-subtag (name)
612  (or (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
613      (nx-error "Type ~s not supported on target ~s"
614                name (backend-target-arch-name *target-backend*))))
615
616(defun nx-target-uvector-subtag-name (subtag)
617  (or (car (rassoc subtag (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
618      (nx-error "Subtag ~s not native on target ~s"
619                subtag (backend-target-arch-name *target-backend*))))
620
621(defun nx-error-for-simple-2d-array-type (type-keyword)
622  (ecase type-keyword
623    (:simple-vector arch::error-object-not-simple-array-t-2d)
624    (:simple-string arch::error-object-not-simple-array-char-2d)
625    (:bit-vector arch::error-object-not-simple-array-bit-2d)
626    (:unsigned-8-bit-vector arch::error-object-not-simple-array-u8-2d)
627    (:signed-8-bit-vector arch::error-object-not-simple-array-s8-2d)
628    (:unsigned-16-bit-vector arch::error-object-not-simple-array-u16-2d)
629    (:signed-16-bit-vector arch::error-object-not-simple-array-s16-2d)
630    (:unsigned-32-bit-vector arch::error-object-not-simple-array-u32-2d)
631    (:signed-32-bit-vector arch::error-object-not-simple-array-s32-2d)
632    (:unsigned-64-bit-vector arch::error-object-not-simple-array-u64-2d)
633    (:signed-64-bit-vector arch::error-object-not-simple-array-s64-2d)
634    (:double-float-vector arch::error-object-not-simple-array-double-float-2d)
635    (:single-float-vector arch::error-object-not-simple-array-single-float-2d)
636    (:fixnum-vector arch::error-object-not-simple-array-fixnum-2d)))
637
638(defun nx-error-for-simple-3d-array-type (type-keyword)
639  (ecase type-keyword
640    (:simple-vector arch::error-object-not-simple-array-t-3d)
641    (:simple-string arch::error-object-not-simple-array-char-3d)
642    (:bit-vector arch::error-object-not-simple-array-bit-3d)
643    (:unsigned-8-bit-vector arch::error-object-not-simple-array-u8-3d)
644    (:signed-8-bit-vector arch::error-object-not-simple-array-s8-3d)
645    (:unsigned-16-bit-vector arch::error-object-not-simple-array-u16-3d)
646    (:signed-16-bit-vector arch::error-object-not-simple-array-s16-3d)
647    (:unsigned-32-bit-vector arch::error-object-not-simple-array-u32-3d)
648    (:signed-32-bit-vector arch::error-object-not-simple-array-s32-3d)
649    (:unsigned-64-bit-vector arch::error-object-not-simple-array-u64-3d)
650    (:signed-64-bit-vector arch::error-object-not-simple-array-s64-3d)
651    (:double-float-vector arch::error-object-not-simple-array-double-float-3d)
652    (:single-float-vector arch::error-object-not-simple-array-single-float-3d)
653    (:fixnum-vector arch::error-object-not-simple-array-fixnum-3d)))
654
655(defun acode-s16-constant-p (x)
656  (setq x (acode-unwrapped-form x))
657  (if (acode-p x)
658    (let* ((op (acode-operator x)))
659      (if (eql op (%nx1-operator fixnum))
660        (let* ((val (cadr x)))
661          (if (target-word-size-case
662               (32 (typep val '(signed-byte #.(- 16 2))))
663               (64 (typep val '(signed-byte #.(- 16 3)))))
664            (ash val (target-word-size-case
665                      (32 2)
666                      (64 3)))))
667        (if (eql op (%nx1-operator %unbound-marker))
668          (arch::target-unbound-marker-value
669           (backend-target-arch *target-backend*))
670          (if (eql op (%nx1-operator %slot-unbound-marker))
671            (arch::target-slot-unbound-marker-value
672             (backend-target-arch *target-backend*))))))))
673
674(defun acode-s32-constant-p (x)
675  (setq x (acode-unwrapped-form x))
676  (if (acode-p x)
677    (let* ((op (acode-operator x)))
678      (if (eql op (%nx1-operator fixnum))
679        (let* ((val (cadr x)))
680          (if (target-word-size-case
681               (32 (typep val '(signed-byte #.(- 32 2))))
682               (64 (typep val '(signed-byte #.(- 32 3)))))
683            (ash val (target-word-size-case
684                      (32 2)
685                      (64 3)))))
686        (if (eql op (%nx1-operator %unbound-marker))
687          (arch::target-unbound-marker-value
688           (backend-target-arch *target-backend*))
689          (if (eql op (%nx1-operator %slot-unbound-marker))
690            (arch::target-slot-unbound-marker-value
691             (backend-target-arch *target-backend*))))))))
692
693(defun acode-fixnum-type-p (form trust-decls)
694  (or (acode-fixnum-form-p form)
695      (and trust-decls
696           (acode-p form)
697           (eq (acode-operator form) (%nx1-operator typed-form))
698           (subtypep (cadr form) 'fixnum))))
699
700
701(defun nx-acode-fixnum-type-p (form env)
702    (acode-fixnum-type-p form (nx-trust-declarations env)))
703
704(defun acode-natural-type-p (form trust-decls)
705  (and trust-decls
706       (acode-p form)
707       (eq (acode-operator form) (%nx1-operator typed-form))
708       (subtypep (cadr form) *nx-target-natural-type*)))
709
710(defun nx-acode-natural-type-p (form env)
711  (acode-natural-type-p form (nx-trust-declarations env)))
712
713; Is acode-expression the result of alphatizing (%int-to-ptr <integer>) ?
714(defun acode-absolute-ptr-p (acode-expression &optional skip)
715  (and (acode-p acode-expression)
716       (or skip (prog1 (eq (acode-operator acode-expression) (%nx1-operator %macptrptr%))
717                  (setq acode-expression (%cadr acode-expression))))
718       (eq (acode-operator acode-expression) (%nx1-operator %consmacptr%))
719       (eq (acode-operator (setq acode-expression (%cadr acode-expression))) 
720           (%nx1-operator %immediate-int-to-ptr))
721       (let ((op (acode-operator (setq acode-expression (%cadr acode-expression)))))
722         (if (or (eq op (%nx1-operator fixnum))
723                 (and (eq op (%nx1-operator immediate))
724                      (integerp (%cadr acode-expression))))
725           (%cadr acode-expression)))))
726
727(defun specifier-type-if-known (typespec &optional env &key whine values)
728  (handler-case (if values (values-specifier-type typespec env) (specifier-type typespec env))
729    (parse-unknown-type (c) 
730      (when (and whine *compiler-warn-on-undefined-type-references*)
731        (nx1-whine (if (keywordp whine) whine :undefined-type) typespec))
732      (values nil (parse-unknown-type-specifier c)))
733    ;; catch any errors due to destructuring in type-expand
734    (program-error (c)
735      (when whine
736        (nx1-whine :invalid-type typespec c))
737      (values nil typespec))))
738
739#+debugging-version
740(defun specifier-type-if-known (typespec &optional env &key whine)
741  (handler-bind ((parse-unknown-type (lambda (c)
742                                       (break "caught unknown-type ~s" c)
743                                       (when (and whine *compiler-warn-on-undefined-type-references*)
744                                         (nx1-whine :undefined-type typespec))
745                                       (return-from specifier-type-if-known
746                                         (values nil (parse-unknown-type-specifier c)))))
747                 (program-error (lambda (c)
748                                  (break "caught program-error ~s" c)
749                                  (when whine
750                                    (nx1-whine :invalid-type typespec c))
751                                  (return-from specifier-type-if-known
752                                    (values nil typespec)))))
753    (specifier-type typespec env)))
754
755(defun nx-check-vdecl-var-ref (decl)
756  (unless (eq (cadr decl) 'special)
757    (let* ((sym (car decl))
758           (info (nx-lex-info sym)))
759      (when (or (eq info :symbol-macro)
760                (and (null info) (not (nx-proclaimed-special-p sym))))
761        (nx1-whine :unknown-declaration-variable (cadr decl) sym)))))
762
763(defun nx-check-fdecl-var-ref (decl env &aux (sym (car decl)))
764  (unless (eq (cadr decl) 'ftype)
765    ;; Complain about forward references, since need a def to use the declaration.
766    ;; Perhaps should complain if regular macro, but don't for now.  Compiler macros
767    ;; specifically allowed by spec for inline decls
768    (unless (or (nx-lexical-finfo sym env)
769                (fboundp sym)
770                (retrieve-environment-function-info sym env)
771                (gethash sym *nx1-alphatizers*)
772                (assq sym *nx-compile-time-compiler-macros*)
773                (gethash sym *compiler-macros*)
774                (eq sym *nx-global-function-name*))
775      (nx1-whine :unknown-declaration-function (cadr decl) sym))))
776
777
778(defun nx-effect-other-decls (pending env)
779  (flet ((merge-decls (new old)
780                      (dolist (decl new old) (pushnew decl old :test #'eq))))
781    (let ((vdecls (pending-declarations-vdecls pending))
782          (fdecls (pending-declarations-fdecls pending))
783          (mdecls (pending-declarations-mdecls pending)))
784      (when vdecls
785        (let ((env-vdecls (lexenv.vdecls env)))
786          (dolist (decl vdecls (setf (lexenv.vdecls env) env-vdecls))
787            (unless (memq decl env-vdecls)
788              (nx-check-vdecl-var-ref decl)
789              (when (eq (cadr decl) 'type)
790                (let* ((var (car decl))
791                       (newtype (cddr decl))
792                       (merged-type (nx1-type-intersect var newtype (nx-declared-type var env))))
793                  (unless (eq merged-type newtype)
794                    (rplacd (cdr decl) merged-type))))
795              (push decl env-vdecls)))))
796      (when fdecls
797        (let ((env-fdecls (lexenv.fdecls env)))
798          (dolist (decl fdecls (setf (lexenv.fdecls env) env-fdecls))
799            (unless (memq decl env-fdecls)
800              (nx-check-fdecl-var-ref decl env)
801              (push decl env-fdecls)))))
802      (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env))))
803      (setq *nx-inlined-self* (and (nx-self-calls-inlineable env) 
804                                   (let ((name *nx-global-function-name*)) 
805                                     (and name (not (nx-declared-notinline-p name env))))))
806      (unless (nx-allow-register-allocation env)
807        (nx-inhibit-register-allocation))
808      (setq *nx-new-p2decls*
809            (if (eql (safety-optimize-quantity env) 3)
810              (logior $decl_full_safety
811                      (if (nx-tailcalls env) $decl_tailcalls 0))
812              (%ilogior
813                (if (nx-tailcalls env) $decl_tailcalls 0)
814                (if (nx-open-code-in-line env) $decl_opencodeinline 0)
815                (if (nx-inhibit-safety-checking env) $decl_unsafe 0)
816                (if (nx-trust-declarations env) $decl_trustdecls 0)))))))
817
818#|     
819(defun nx-find-misc-decl (declname env)
820  (loop
821    (unless (and env (eq (uvref env 0) 'lexical-environment)) (return))
822    (dolist (mdecl (lexenv.mdecls env))
823      (if (atom mdecl)
824        (if (eq mdecl declname)
825          (return-from nx-find-misc-decl t))
826        (if (eq (%car mdecl) declname)
827          (return-from nx-find-misc-decl (%cdr mdecl)))))
828    (setq env (lexenv.parent-env env))))
829|#
830
831
832(defun nx-bad-decls (decls)
833  (nx1-whine :bad-declaration decls))
834
835
836(defnxdecl special (pending decl env &aux whined)
837  (declare (ignore env))
838  (dolist (s (%cdr decl))
839    (if (symbolp s) 
840      (nx-new-vdecl pending s 'special)
841      (unless (shiftf whined t) (nx-bad-decls decl)))))
842
843(defnxdecl notspecial (pending decl env &aux whined)
844  (declare (ignore env))
845  (dolist (s (%cdr decl))
846    (if (symbolp s)
847      (nx-new-vdecl pending s 'notspecial)
848      (unless (shiftf whined t) (nx-bad-decls decl)))))
849
850(defnxdecl dynamic-extent (pending decl env &aux whined)
851  (declare (ignore env))
852  (dolist (s (%cdr decl))
853    (if (symbolp s) 
854      (nx-new-vdecl pending s 'dynamic-extent t)
855      (if (and (consp s)
856               (eq (%car s) 'function)
857               (consp (%cdr s))
858               (valid-function-name-p (cadr s))
859               (setq s (validate-function-name (cadr s))))
860        (nx-new-fdecl pending s 'dynamic-extent t)
861        (unless (shiftf whined t) (nx-bad-decls decl))))))
862
863(defnxdecl ignorable (pending decl env &aux whined)
864  (declare (ignore env))
865  (dolist (s (%cdr decl))
866    (if (symbolp s) 
867      (nx-new-vdecl pending s 'ignorable)
868      (if (and (consp s)
869               (eq (%car s) 'function)
870               (consp (%cdr s))
871               (valid-function-name-p (cadr s))
872               (setq s (validate-function-name (cadr s))))
873        (nx-new-fdecl pending s 'ignorable)
874        (unless (shiftf whined t) (nx-bad-decls decl))))))
875
876(defnxdecl ftype (pending decl env &aux whined)
877  (destructuring-bind (type &rest fnames) (%cdr decl)
878    (let ((ctype (specifier-type-if-known type env :whine :unknown-type-in-declaration)))
879      (when ctype
880        (if (types-disjoint-p ctype (specifier-type 'function))
881          (nx-bad-decls decl)
882          (dolist (s fnames)
883            (if (or (symbolp s) (setf-function-name-p s))
884              (nx-new-fdecl pending s 'ftype type)
885              (unless (shiftf whined t) (nx-bad-decls decl)))))))))
886
887(defnxdecl settable (pending decl env)
888  (nx-settable-decls pending decl env t))
889
890(defnxdecl unsettable (pending decl env)
891  (nx-settable-decls pending decl env nil))
892
893(defun nx-settable-decls (pending decl env val &aux whined)
894  (declare (ignore env))
895  (dolist (s (%cdr decl))
896    (if (symbolp s)
897      (nx-new-vdecl pending s 'settable val)
898      (unless (shiftf whined t) (nx-bad-decls decl)))))
899
900(defnxdecl function (pending decl env)
901  (nx-process-type-decl pending decl (car decl) (cdr decl) env))
902
903(defnxdecl type (pending decl env)
904  (nx-process-type-decl pending decl (cadr decl) (cddr decl) env))
905
906(defun nx-process-type-decl (pending decl type vars env &aux whined)
907  (when (specifier-type-if-known type env :whine :unknown-type-in-declaration)
908    (dolist (sym vars)
909      (if (symbolp sym)
910        (nx-new-vdecl pending sym 'type type)
911        (unless (shiftf whined t) (nx-bad-decls decl))))))
912
913(defnxdecl global-function-name (pending decl env)
914  (declare (ignore pending))
915  (when *nx-parsing-lambda-decls*
916    (let ((name (cadr decl)))
917      (setq *nx-global-function-name* (setf (afunc-name *nx-current-function*) name))
918      (setq *nx-inlined-self* (not (nx-declared-notinline-p name env))))))
919
920(defnxdecl debugging-function-name (pending decl env)
921  (declare (ignore pending env))
922  (when *nx-parsing-lambda-decls*
923    (setf (afunc-name *nx-current-function*) (cadr decl))))
924
925(defnxdecl resident (pending decl env)
926  (declare (ignore env pending))
927  (declare (ignore decl))
928  (nx-decl-set-fbit $fbitresident))
929
930
931(defun nx-inline-decl (pending decl val &aux valid-name whined)
932  (dolist (s (%cdr decl))
933    (multiple-value-setq (valid-name s) (valid-function-name-p s))
934    (if valid-name
935      (progn
936        (if (nx-self-call-p s nil t)
937          (setq *nx-inlined-self* val))
938        (nx-new-fdecl pending s 'inline (if val 'inline 'notinline)))
939      (unless (shiftf whined t) (nx-bad-decls decl)))))
940
941(defnxdecl inline (pending decl env)
942  (declare (ignore env))
943  (nx-inline-decl pending decl t))
944
945(defnxdecl notinline (pending decl env)
946  (declare (ignore env))
947  (nx-inline-decl pending decl nil))
948
949(defnxdecl ignore (pending decl env &aux whined)
950  (declare (ignore env))
951  (dolist (s (%cdr decl))
952    (if (symbolp s)     
953      (nx-new-vdecl pending s 'ignore t)
954      (if (and (consp s)
955               (eq (%car s) 'function)
956               (consp (%cdr s))
957               (valid-function-name-p (cadr s))
958               (setq s (validate-function-name (cadr s))))
959        (nx-new-fdecl pending s 'ignore t)
960        (unless (shiftf whined t) (nx-bad-decls decl))))))
961
962(defnxdecl ignore-if-unused (pending decl env &aux whined)
963  (declare (ignore env))
964  (dolist (s (%cdr decl))
965    (if (symbolp s) 
966      (nx-new-vdecl pending s 'ignore-if-unused)
967      (unless (shiftf whined t) (nx-bad-decls decl)))))
968
969(defun nx-self-call-p (name &optional ignore-lexical (allow *nx-inlined-self*))
970  (when (and name (symbolp name))
971    (let ((current-afunc *nx-current-function*)
972          (target-afunc (unless ignore-lexical (nth-value 1 (nx-lexical-finfo name)))))
973      (or (eq current-afunc target-afunc)
974          (and allow
975               (eq name *nx-global-function-name*)
976               (null target-afunc)
977               (null (afunc-parent current-afunc)))))))
978
979(defun nx-check-var-usage (var)
980  (let* ((sym (var-name var))
981         (bits (nx-var-bits var))
982         (expansion (var-ea var))
983         (setqed (%ilogbitp $vbitsetq bits))
984         (reffed (%ilogbitp $vbitreffed bits))
985         (closed (%ilogbitp $vbitclosed bits))
986         (special (%ilogbitp $vbitspecial bits))
987         (ignored (%ilogbitp $vbitignore bits))
988         (ignoreunused (%ilogbitp $vbitignoreunused bits)))
989    (if (or special reffed closed)
990      (progn
991        (if ignored (nx1-whine :ignore sym))
992        (nx-set-var-bits var (%ilogand (nx-check-downward-vcell var bits) (%ilognot (%ilsl $vbitignore 1)))))
993      (progn
994        (if (and setqed ignored) (nx1-whine :ignore sym))
995        (or ignored ignoreunused 
996            (progn (and (consp expansion) (eq (car expansion) :symbol-macro) (setq sym (list :symbol-macro sym))) (nx1-whine :unused sym)))
997        (when (%izerop (%ilogand bits (%ilogior $vrefmask $vsetqmask)))
998          (nx-set-var-bits var (%ilogior (%ilsl $vbitignore 1) bits)))))))
999
1000; if an inherited var isn't setqed, it gets no vcell.  If it -is- setqed, but
1001; all inheritors are downward, the vcell can be stack-consed.  Set a bit so that
1002; the right thing happens when the var is bound.
1003; Set the bit for the next-method var even if it is not setqed.
1004(defun nx-check-downward-vcell (v bits)
1005  (if (and (%ilogbitp $vbitclosed bits)
1006           (or (%ilogbitp $vbitsetq bits)
1007               (eq v *nx-next-method-var*))
1008           (nx-afuncs-downward-p v (afunc-inner-functions *nx-current-function*)))
1009    (%ilogior (%ilsl $vbitcloseddownward 1) bits)
1010    bits))
1011
1012; afunc is "downward wrt v" if it doesn't inherit v or if all refs to afunc
1013; are "downward" and no inner function of afunc is not downward with respect to v.
1014(defun nx-afunc-downward-p (v afunc)
1015  (or (dolist (i (afunc-inherited-vars afunc) t)
1016        (when (eq (nx-root-var i) v) (return nil)))
1017      (if (nx-afuncs-downward-p v (afunc-inner-functions afunc))
1018        (eq (afunc-fn-refcount afunc)
1019            (afunc-fn-downward-refcount afunc)))))
1020
1021(defun nx-afuncs-downward-p (v afuncs)
1022  (dolist (afunc afuncs t)
1023    (unless (nx-afunc-downward-p v afunc) (return nil))))
1024
1025(defun nx1-punt-bindings (vars initforms)
1026  (dolist (v vars)
1027    (nx1-punt-var v (pop initforms))))
1028
1029;;; at the beginning of a binding construct, note which lexical
1030;;; variables are bound to other variables and the number of setqs
1031;;; done so far on the initform.  After executing the body, if neither
1032;;; variable has been closed over, the new variable hasn't been
1033;;; setq'ed, and the old guy wasn't setq'ed in the body, the binding
1034;;; can be punted.
1035(defun nx1-note-var-binding (var initform)
1036  (let* ((init (nx-untyped-form initform))
1037         (inittype (nx-acode-form-type initform *nx-lexical-environment*))
1038         (bits (nx-var-bits var)))
1039    (when (%ilogbitp $vbitspecial bits) (nx-record-xref-info :binds (var-name var)))
1040    (when inittype (setf (var-inittype var) inittype))
1041    (when (and (not (%ilogbitp $vbitspecial bits))
1042               (acode-p init))
1043      (let* ((op (acode-operator init)))
1044        (if (eq op (%nx1-operator lexical-reference))
1045          (let* ((target (%cadr init))
1046                 (setq-count (%ilsr 8 (%ilogand $vsetqmask (nx-var-bits target)))))
1047            (unless (eq setq-count (%ilsr 8 $vsetqmask))
1048              (cons var (cons setq-count target))))
1049          (if (and (%ilogbitp $vbitdynamicextent bits)
1050                   (or (eq op (%nx1-operator closed-function))
1051                       (eq op (%nx1-operator simple-function))))
1052            (let* ((afunc (%cadr init)))
1053              (setf (afunc-fn-downward-refcount afunc)
1054                    (afunc-fn-refcount afunc)
1055                    (afunc-bits afunc) (logior (ash 1 $fbitdownward) (ash 1 $fbitbounddownward)
1056                                               (the fixnum (afunc-bits afunc))))
1057              nil)))))))
1058
1059
1060;;; Process entries involving variables bound to other variables at
1061;;; the end of a binding construct.  Each entry is of the form
1062;;; (source-var setq-count . target-var), where setq-count is the
1063;;; assignment count of TARGET-VAR at the time that the binding's
1064;;; initform was evaluated (not, in the case of LET, at the time that
1065;;; the bindinw was established.).  If the target isn't closed-over
1066;;; and SETQed (somewhere), and wasn't setqed in the body (e.g.,
1067;;; still has the same assignment-count as it had when the initform
1068;;; was executed), then we can "punt" the source (and replace references
1069;;; to it with references to the target.)
1070;;; It obviously makes no sense to do this if the source is SPECIAL;
1071;;; in some cases (LET), we create the source variable and add it to
1072;;; this alist before it's known whether or not the source variable
1073;;; is SPECIAL. so we have to ignore that case here.
1074(defun nx1-check-var-bindings (alist)
1075  (dolist (pair alist)
1076    (let* ((var (car pair))
1077           (target (cddr pair))
1078           (vbits (nx-var-bits var))
1079           (target-bits (nx-var-bits target)))
1080      (unless (or
1081               ;; var can't be special, setq'ed or closed; target can't be
1082               ;; setq'ed AND closed.
1083               (neq (%ilogand vbits (%ilogior (%ilsl $vbitsetq 1)
1084                                              (%ilsl $vbitclosed 1)
1085                                              (%ilsl $vbitspecial 1))) 0)
1086               (eq (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1)) 
1087                   (%ilogand
1088                     (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1))
1089                     target-bits))
1090               (neq (%ilsr 8 (%ilogand $vsetqmask target-bits)) (cadr pair)))
1091             (push (cons var target) *nx-punted-vars*)))))
1092
1093(defun nx1-punt-var (var initform)
1094  (let* ((bits (nx-var-bits var))
1095         (mask (%ilogior (%ilsl $vbitsetq 1) (ash -1 $vbitspecial) (%ilsl $vbitclosed 1)))
1096         (nrefs (%ilogand $vrefmask bits))
1097         (val (nx-untyped-form initform))
1098         (op (if (acode-p val) (acode-operator val))))
1099    (when (%izerop (%ilogand mask bits))
1100      (if
1101        (or 
1102         (nx-t val)
1103         (nx-null val)
1104         (and (eql nrefs 1) (not (logbitp $vbitdynamicextent bits)) ( acode-absolute-ptr-p val t))
1105         (eq op (%nx1-operator fixnum))
1106         (eq op (%nx1-operator immediate)))
1107        (progn
1108          (nx-set-var-bits var (%ilogior (%ilsl $vbitpuntable 1) bits)))))
1109    (when (and (%ilogbitp $vbitdynamicextent bits)
1110               (or (eq op (%nx1-operator closed-function))
1111                   (eq op (%nx1-operator simple-function))))
1112      (let* ((afunc (cadr val)))
1113        (setf (afunc-bits afunc) (%ilogior (%ilsl $fbitbounddownward 1) (afunc-bits afunc))
1114              (afunc-fn-downward-refcount afunc) 1))) 
1115    nil))
1116           
1117(defnxdecl optimize (pending specs env)
1118  (declare (ignore env))
1119  (let* ((q nil)
1120         (v nil)
1121         (mdecls (pending-declarations-mdecls pending)))
1122    (dolist (spec (%cdr specs) (setf (pending-declarations-mdecls pending) mdecls))
1123      (if (atom spec)
1124        (setq q spec v 3)
1125        (setq q (%car spec) v (cadr spec)))
1126      (if (and (fixnump v) (<= 0 v 3) (memq q '(speed space compilation-speed safety debug)))
1127        (push (cons q v) mdecls)
1128        (nx-bad-decls spec)))))
1129
1130(defun %proclaim-optimize (specs &aux q v)
1131  (dolist (spec specs)
1132    (if (atom spec)
1133      (setq q spec v 3)
1134      (setq q (%car spec) v (cadr spec)))
1135    (or (and (fixnump v)
1136             (<= 0 v 3)
1137             (case q
1138               (speed (setq *nx-speed* v))
1139               (space (setq *nx-space* v))
1140               (compilation-speed (setq *nx-cspeed* v))
1141               (safety (setq *nx-safety* v))
1142               (debug (setq *nx-debug* v))))
1143        (bad-proclaim-spec `(optimize ,spec)))))
1144
1145(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*))
1146  (let* ((info nil)
1147         (barrier-crossed nil))
1148    (if env
1149      (loop
1150        (when (eq 'barrier (lexenv.variables env))
1151          (setq barrier-crossed t))
1152        (when (setq info (%cdr (assq sym (lexenv.functions env))))
1153          (return (values info (if (and (eq (car info) 'function)
1154                                        (consp (%cdr info)))
1155                                 (progn
1156                                   (when barrier-crossed
1157                                     (nx-error "Illegal reference to lexically-defined function ~S." sym))
1158                                   (%cadr info))))))
1159        (if (listp (setq env (lexenv.parent-env env)))
1160          (return (values nil nil))))
1161      (values nil nil))))
1162
1163(defun nx-inline-expansion (sym &optional (env *nx-lexical-environment*) global-only)
1164  (let* ((lambda-form nil)
1165         (containing-env nil)
1166         (token nil))
1167    (if (and (nx-declared-inline-p sym env)
1168             (not (gethash sym *nx1-alphatizers*))
1169             (not *nx-current-code-note*))
1170      (multiple-value-bind (info afunc) (unless global-only (nx-lexical-finfo sym env))
1171        (if info (setq token afunc 
1172                       containing-env (afunc-environment afunc)
1173                       lambda-form (afunc-lambdaform afunc)))
1174        (setq info (cdr (retrieve-environment-function-info sym env)))
1175        (if (def-info.lambda info)
1176            (setq lambda-form (def-info.lambda info)
1177                  token sym
1178                  containing-env (new-lexical-environment (definition-environment env)))
1179            (unless info
1180              (if (cdr (setq info (assq sym *nx-globally-inline*)))
1181                (setq lambda-form (%cdr info)
1182                      token sym
1183                      containing-env (new-lexical-environment (new-definition-environment nil))))))))
1184    (values lambda-form (nx-closed-environment env containing-env) token)))
1185
1186(defun nx-closed-environment (current-env target)
1187  (when target
1188    (let* ((intervening-functions nil))
1189      (do* ((env current-env (lexenv.parent-env env)))
1190           ((or (eq env target) (null env) (istruct-typep env 'definition-environment)))
1191        (let* ((fn (lexenv.lambda env)))
1192          (when fn (push fn intervening-functions))))
1193      (let* ((result target))
1194        (dolist (fn intervening-functions result)
1195          (setf (lexenv.lambda (setq result (new-lexical-environment result))) fn))))))
1196
1197(defun nx-root-var (v)
1198  (do* ((v v bits)
1199        (bits (var-bits v) (var-bits v)))
1200       ((fixnump bits) v)))
1201
1202(defun nx-reconcile-inherited-vars (more)
1203  (let ((last nil)) ; Bop 'til ya drop.
1204    (loop
1205      (setq last more more nil)
1206      (dolist (callee last)
1207        (dolist (caller (afunc-callers callee))
1208          (unless (or (eq caller callee)
1209                      (eq caller (afunc-parent callee)))
1210            (dolist (v (afunc-inherited-vars callee))
1211              (let ((root-v (nx-root-var v)))
1212                (unless (dolist (caller-v (afunc-inherited-vars caller))
1213                          (when (eq root-v (nx-root-var caller-v))
1214                            (return t)))
1215                  ; caller must inherit root-v in order to call callee without using closure.
1216                  ; can't just bind afunc & call nx-lex-info here, 'cause caller may have
1217                  ; already shadowed another var with same name.  So:
1218                  ; 1) find the ancestor of callee which bound v; this afunc is also an ancestor
1219                  ;    of caller
1220                  ; 2) ensure that each afunc on the inheritance path from caller to this common
1221                  ;    ancestor inherits root-v.
1222                  (let ((ancestor (afunc-parent callee))
1223                        (inheritors (list caller)))
1224                    (until (eq (setq v (var-bits v)) root-v)
1225                      (setq ancestor (afunc-parent ancestor)))
1226                    (do* ((p (afunc-parent caller) (afunc-parent p)))
1227                         ((eq p ancestor))
1228                      (push p inheritors))
1229                    (dolist (f inheritors)
1230                      (setq v (nx-cons-var (var-name v) v))
1231                      (unless (dolist (i (afunc-inherited-vars f))
1232                                (when (eq root-v (nx-root-var i))
1233                                  (return (setq v i))))
1234                        (pushnew f more)
1235                        (push v (afunc-inherited-vars f))
1236                        ; change shared structure of all refs in acode with one swell foop.
1237                        (nx1-afunc-ref f))))))))))   
1238      (unless more (return)))))
1239
1240(defun nx-inherit-var (var binder current)
1241  (if (eq binder current)
1242    (progn
1243      (nx-set-var-bits var (%ilogior2 (%ilsl $vbitclosed 1) (nx-var-bits var)))
1244      var)
1245    (let ((sym (var-name var)))
1246      (or (dolist (already (afunc-inherited-vars current))
1247            (when (eq sym (var-name already)) (return already)))
1248          (progn
1249            (setq var (nx-cons-var sym (nx-inherit-var var binder (afunc-parent current))))
1250            (push var (afunc-inherited-vars current))
1251            var)))))
1252
1253(defun nx-lex-info (sym &optional current-only)
1254  (let* ((current-function *nx-current-function*)
1255         (catch nil)
1256         (barrier-crossed nil))
1257    (multiple-value-bind 
1258      (info afunc)
1259      (do* ((env *nx-lexical-environment* (lexenv.parent-env env))
1260            (continue env (and env (not (istruct-typep env 'definition-environment))))
1261            (binder current-function (or (if continue (lexenv.lambda env)) binder)))
1262           ((or (not continue) (and (neq binder current-function) current-only)) 
1263            (values nil nil))
1264        (let ((vars (lexenv.variables env)))
1265          (if (eq vars 'catch) 
1266            (setq catch t)
1267            (if (eq vars 'barrier)
1268              (setq barrier-crossed t)
1269              (let ((v (dolist (var vars)
1270                         (when (eq (var-name var) sym) (return var)))))
1271                (when v (return (values v binder)))
1272                (dolist (decl (lexenv.vdecls env))
1273                  (when (and (eq (car decl) sym)
1274                             (eq (cadr decl) 'special))
1275                    (return-from nx-lex-info (values :special nil nil)))))))))
1276      (if info
1277        (if (var-expansion info)
1278          (values :symbol-macro (cdr (var-expansion info)) info)
1279          (if (%ilogbitp $vbitspecial (nx-var-bits info))
1280            (values :special info nil)
1281            (if barrier-crossed
1282              (nx-error "Illegal reference to lexically defined variable ~S." sym)
1283              (if (eq afunc current-function)
1284                (values info nil catch)
1285                (values (nx-inherit-var info afunc current-function) t catch)))))
1286        (values nil nil nil)))))
1287
1288
1289(defun nx-block-info (blockname &optional (afunc *nx-current-function*) &aux
1290  blocks
1291  parent
1292  (toplevel (eq afunc *nx-current-function*))
1293  blockinfo)
1294 (when afunc
1295  (setq
1296   blocks (if toplevel *nx-blocks* (afunc-blocks afunc))
1297   blockinfo (assq blockname blocks)
1298   parent (afunc-parent afunc))
1299  (if blockinfo
1300   (values blockinfo nil)
1301   (when parent
1302    (when (setq blockinfo (nx-block-info blockname parent))
1303     (values blockinfo t))))))
1304
1305(defun nx-tag-info (tagname &optional (afunc *nx-current-function*) &aux
1306                            tags
1307                            parent
1308                            index
1309                            counter
1310                            (toplevel (eq afunc *nx-current-function*))
1311                            taginfo)
1312  (when afunc
1313    (setq
1314     tags (if toplevel *nx-tags* (afunc-tags afunc))
1315     taginfo (assoc tagname tags)
1316     parent (afunc-parent afunc))
1317    (if taginfo
1318      (values taginfo nil)
1319      (when (and parent (setq taginfo (nx-tag-info tagname parent)))
1320        (unless (setq index (cadr taginfo))
1321          (setq counter (caddr taginfo))
1322          (%rplaca counter (%i+ (%car counter) 1))
1323          (setq index (%car counter))
1324          (%rplaca (%cdr taginfo) index))
1325        (values taginfo index)))))
1326
1327(defun nx1-transitively-punt-bindings (pairs) 
1328  (dolist (pair (nreverse pairs))
1329    (let* ((var         (%car pair))
1330           (boundto     (%cdr pair))
1331           (varbits     (nx-var-bits var))
1332           (boundtobits (nx-var-bits boundto)))
1333      (declare (fixnum varbits boundtobits))
1334      (unless (eq (%ilogior
1335                    (%ilsl $vbitsetq 1)
1336                    (%ilsl $vbitclosed 1))
1337                  (%ilogand
1338                    (%ilogior
1339                      (%ilsl $vbitsetq 1)
1340                      (%ilsl $vbitclosed 1))
1341                    boundtobits))
1342        ;; Can't happen -
1343        (unless (%izerop (%ilogand (%ilogior
1344                                     (%ilsl $vbitsetq 1) 
1345                                     (ash -1 $vbitspecial)
1346                                     (%ilsl $vbitclosed 1)) varbits))
1347          (error "Bug-o-rama - \"punted\" var had bogus bits. ~
1348Or something. Right? ~s ~s" var varbits))
1349        (let* ((varcount     (%ilogand $vrefmask varbits)) 
1350               (boundtocount (%ilogand $vrefmask boundtobits)))
1351          (nx-set-var-bits var (%ilogior
1352                                 (%ilsl $vbitpuntable 1)
1353                                 (%i- varbits varcount)))
1354          (setf (var-refs var) (+ (var-refs var) (var-refs boundto)))
1355          (nx-set-var-bits
1356           boundto
1357           (%i+ (%i- boundtobits boundtocount)
1358                (%ilogand $vrefmask
1359                          (%i+ (%i- boundtocount 1) varcount)))))))))
1360
1361;;; Home-baked handler-case replacement.  About 10 times as fast as full handler-case.
1362;;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds
1363;;;(LET ((S 0)) (DOTIMES (I 1000000) (BLOCK X (ERROR (CATCH 'X (RETURN-FROM X (INCF S))))))) took 57,485
1364;;;(LET ((S 0)) (DOTIMES (I 1000000) (HANDLER-CASE (INCF S) (ERROR (C) C)))) took 168,947
1365(defmacro with-program-error-handler (handler &body body)
1366  (let ((tag (gensym)))
1367    `(block ,tag
1368       (,handler (catch 'program-error-handler (return-from ,tag (progn ,@body)))))))
1369
1370(defun runtime-program-error-form (c)
1371  `(signal-program-error "Invalid program: ~a" ,(princ-to-string c)))
1372
1373(defun nx1-compile-lambda (name lambda-form &optional
1374                                 (p (make-afunc))
1375                                 q
1376                                 parent-env
1377                                 (policy *default-compiler-policy*)
1378                                 load-time-eval-token)
1379
1380  (if q
1381     (setf (afunc-parent p) q))
1382
1383  ;; In the case of a method function, the name will get reset at load time to the
1384  ;; method object.  However, during compilation, we want any inner functions to use
1385  ;; the fully qualified method name, so store that.
1386  (when (method-lambda-p lambda-form)
1387    (setq name (or *nx-method-warning-name* name)))
1388
1389  (setf (afunc-name p)
1390        (let ((parent-name (and (afunc-parent p) (afunc-name (afunc-parent p)))))
1391          (if parent-name
1392            (if (and (consp parent-name) (eq (%car parent-name) :internal))
1393              (if name
1394                `(:internal ,name ,@(cdr parent-name))
1395                parent-name)
1396              (if name
1397                `(:internal ,name ,parent-name)
1398                `(:internal ,parent-name)))
1399            name)))
1400
1401  (unless (lambda-expression-p lambda-form)
1402    (nx-error "~S is not a valid lambda expression." lambda-form))
1403
1404  (let* ((*nx-current-function* p)
1405         (*nx-parent-function* q)
1406         (*nx-current-note* (or *nx-current-note* (nx-source-note lambda-form)))
1407         (*nx-lexical-environment* (new-lexical-environment parent-env))
1408         (*nx-load-time-eval-token* load-time-eval-token)
1409         (*nx-all-vars* nil)
1410         (*nx-bound-vars* nil)
1411         (*nx-punted-vars* nil)
1412         (*nx-current-compiler-policy* policy)
1413         (*nx-blocks* nil)
1414         (*nx-tags* nil)
1415         (*nx-loop-nesting-level* 0)
1416         (*nx-inner-functions* nil)
1417         (*nx-global-function-name* nil)
1418         (*nx-warnings* nil)
1419         (*nx1-fcells* nil)
1420         (*nx1-vcells* nil)
1421         (*nx-inline-expansions* nil)
1422         (*nx-parsing-lambda-decls* nil)
1423         (*nx-next-method-var* (if q *nx-next-method-var*))
1424         (*nx-call-next-method-function* (if q *nx-call-next-method-function*))
1425         (*nx-cur-func-name* name))
1426    (if (%non-empty-environment-p *nx-lexical-environment*)
1427      (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p)))))
1428
1429    (setf (afunc-lambdaform p) lambda-form)
1430
1431    (when *nx-current-note*
1432      (setf (afunc-lfun-info p)
1433            (list* '%function-source-note *nx-current-note* (afunc-lfun-info p))))
1434
1435    (with-program-error-handler
1436        (lambda (c)
1437          (setf (afunc-acode p) (nx1-lambda '(&rest args) `(args ,(runtime-program-error-form c)) nil)))
1438      (handler-bind ((warning (lambda (c)
1439                                (nx1-whine :program-error c)
1440                                (muffle-warning c)))
1441                     (program-error (lambda (c)
1442                                      (when *nx-break-on-program-errors*
1443                                        (cerror "continue compilation ignoring this form" c))
1444                                      (when (typep c 'compile-time-program-error)
1445                                        (setq c (make-condition 'simple-program-error
1446                                                                :format-control (simple-condition-format-control c)
1447                                                                :format-arguments (simple-condition-format-arguments c))))
1448                                      (unless *nx-break-on-program-errors*
1449                                        (nx1-whine :program-error c))
1450                                      (throw 'program-error-handler c))))
1451        (multiple-value-bind (body decls)
1452            (with-program-error-handler (lambda (c) (runtime-program-error-form c))
1453              (parse-body (%cddr lambda-form) *nx-lexical-environment* t))
1454          (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
1455
1456    (nx1-transitively-punt-bindings *nx-punted-vars*)
1457    (setf (afunc-blocks p) *nx-blocks*)
1458    (setf (afunc-tags p) *nx-tags*)
1459    (setf (afunc-inner-functions p) *nx-inner-functions*)
1460    (setf (afunc-all-vars p) *nx-all-vars*)
1461    (setf (afunc-vcells p) *nx1-vcells*)
1462    (setf (afunc-fcells p) *nx1-fcells*)
1463    (when *nx-current-code-note*
1464      (when (null q) ;; toplevel functions only
1465        (nx-record-code-coverage-acode p)))
1466    (let* ((warnings (merge-compiler-warnings *nx-warnings*))
1467           (name *nx-cur-func-name*))       
1468      (dolist (inner *nx-inner-functions*)
1469        (dolist (w (afunc-warnings inner))
1470          (push name (compiler-warning-function-name w))
1471          (push w warnings)))
1472      (setf (afunc-warnings p) warnings))
1473    p))
1474
1475(defun method-lambda-p (form)
1476  (and (consp form)
1477       (consp (setq form (%cdr form)))       
1478       (eq (caar form) '&method)))
1479
1480
1481(defun nx1-lambda (ll body decls &aux (l ll) methvar)
1482  (let* ((old-env *nx-lexical-environment*)
1483         (*nx-bound-vars* *nx-bound-vars*))
1484    (with-nx-declarations (pending)
1485      (let* ((*nx-parsing-lambda-decls* t))
1486        (nx-process-declarations pending decls))
1487      (when (eq (car l) '&lap)
1488        (let ((bits nil))
1489          (unless (and (eq (length (%cdr l)) 1) (fixnump (setq bits (%cadr l))))
1490            (unless (setq bits (encode-lambda-list (%cdr l)))
1491              (nx-error "invalid lambda-list  - ~s" l)))
1492          (return-from nx1-lambda
1493                       (make-acode
1494                        (%nx1-operator lambda-list)
1495                        (list (cons '&lap bits))
1496                        nil
1497                        nil
1498                        nil
1499                        nil
1500                        (nx1-env-body body old-env)
1501                        *nx-new-p2decls*))))
1502      (when (eq (car l) '&method)
1503        (setf (afunc-bits *nx-current-function*)
1504              (%ilogior (%ilsl $fbitmethodp 1)
1505                        (afunc-bits *nx-current-function*)))
1506        (setq *nx-inlined-self* nil)
1507        (setq *nx-next-method-var* (setq methvar (let ((var (nx-new-var
1508                                                             pending
1509                                                             (%cadr ll))))
1510                                                   (nx-set-var-bits var (%ilogior 
1511                                                                          (%ilsl $vbitignoreunused 1) 
1512                                                                          ;(%ilsl $vbitnoreg 1)
1513                                                                          (nx-var-bits var)))
1514                                                   var)))
1515                                                   
1516        (setq ll (%cddr ll)))
1517      (multiple-value-bind (req opt rest keys auxen lexpr)
1518                           (nx-parse-simple-lambda-list pending ll)
1519        (nx-effect-other-decls pending *nx-lexical-environment*)
1520        (setq body (nx1-env-body body old-env))
1521        (nx1-punt-bindings (%car auxen) (%cdr auxen))
1522        (when methvar
1523          (push methvar req)
1524          (unless (eq 0 (%ilogand (%ilogior (%ilsl $vbitreffed 1)
1525                                            (%ilsl $vbitclosed 1)
1526                                            (%ilsl $vbitsetq 1))
1527                                  (nx-var-bits methvar)))
1528            (setf (afunc-bits *nx-current-function*)
1529                  (%ilogior 
1530                   (%ilsl $fbitnextmethp 1)
1531                   (afunc-bits *nx-current-function*)))))
1532        (let ((acode (make-acode
1533                      (%nx1-operator lambda-list) 
1534                      req
1535                      opt 
1536                      (if lexpr (list rest) rest)
1537                      keys
1538                      auxen
1539                      body
1540                      *nx-new-p2decls*)))
1541          (when *nx-current-code-note*
1542            (setf (acode-note acode) *nx-current-code-note*))
1543          acode)))))
1544
1545(defun nx-parse-simple-lambda-list (pending ll &aux
1546                                              req
1547                                              opt
1548                                              rest
1549                                              keys
1550                                              lexpr
1551                                              sym)
1552  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail)
1553                       (verify-lambda-list ll)
1554    (unless ok (nx-error "Bad lambda list : ~S" ll))
1555    (dolist (var reqsyms)
1556      (push (nx-new-var pending var t) req))
1557    (when (eq (pop opttail) '&optional)
1558      (let* (optvars optinits optsuppliedp)
1559        (until (eq opttail resttail) 
1560          (setq sym (pop opttail))
1561          (let* ((var sym)
1562                 (initform nil)
1563                 (spvar nil))
1564            (when (consp var)
1565              (setq sym (pop var) initform (pop var) spvar (%car var)))
1566            (push (nx1-typed-var-initform pending sym initform) optinits)
1567            (push (nx-new-var pending sym t) optvars)
1568            (push (if spvar (nx-new-var pending spvar t)) optsuppliedp)))
1569        (if optvars
1570          (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
1571          (nx1-whine :lambda ll))))
1572    (let ((temp (pop resttail)))
1573      (when (or (eq temp '&rest)
1574                (setq lexpr (eq temp '&lexpr)))
1575        (setq rest (nx-new-var pending (%car resttail) t))))
1576    (when (eq (%car keytail) '&key) 
1577      (setq keytail (%cdr keytail))
1578      (let* ((keysyms ())
1579             (keykeys ())
1580             (keyinits ())
1581             (keysupp ())
1582             (kallowother (not (null (memq '&allow-other-keys ll))))
1583             (kvar ())
1584             (kkey ())
1585             (kinit ())
1586             (ksupp))
1587        (until (eq keytail auxtail)
1588          (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
1589            (setq kinit *nx-nil* ksupp nil)
1590            (if (atom sym)
1591              (setq kvar sym kkey (make-keyword sym))
1592              (progn
1593                (if (consp (%car sym))
1594                  (setq kkey (%caar sym) kvar (%cadar sym))
1595                  (progn
1596                    (setq kvar (%car sym))
1597                    (setq kkey (make-keyword kvar))))
1598                (setq kinit (nx1-typed-var-initform pending kvar (%cadr sym)))
1599                (setq ksupp (%caddr sym))))
1600            (push (nx-new-var pending kvar t) keysyms)
1601            (push kkey keykeys)
1602            (push kinit keyinits)
1603            (push (if ksupp (nx-new-var pending ksupp t)) keysupp)))
1604        (setq 
1605         keys
1606         (list
1607          kallowother
1608          (nreverse keysyms)
1609          (nreverse keysupp)
1610          (nreverse keyinits)
1611          (apply #'vector (nreverse keykeys))))))
1612    (let (auxvals auxvars)
1613      (dolist (pair (%cdr auxtail))
1614        (let* ((auxvar (nx-pair-name pair))
1615               (auxval (nx1-typed-var-initform pending auxvar (nx-pair-initform pair))))
1616          (push auxval auxvals)
1617          (push (nx-new-var pending auxvar t) auxvars)))
1618      (values
1619       (nreverse req) 
1620       opt 
1621       rest
1622       keys
1623       (list (nreverse auxvars) (nreverse auxvals))
1624       lexpr))))
1625
1626(defun nx-new-structured-var (pending sym)
1627  (if sym
1628    (nx-new-var pending sym t)
1629    (nx-new-temp-var pending)))
1630
1631(defun nx-parse-structured-lambda-list (pending ll &optional no-acode whole-p &aux
1632                                           req
1633                                           opt
1634                                           rest
1635                                           keys
1636                                           sym)
1637  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail all whole structured-p)
1638                       (verify-lambda-list ll t whole-p nil)
1639    (declare (ignore all))
1640    (unless ok (nx-error "Bad lambda list : ~S" ll))
1641    (if (or whole (and whole-p structured-p)) (setq whole (nx-new-structured-var pending whole)))
1642    (dolist (var reqsyms)
1643      (push (if (symbolp var)
1644                    (nx-new-structured-var pending var)
1645                    (nx-structured-lambda-form pending var no-acode))
1646                  req))
1647    (when (eq (pop opttail) '&optional)
1648      (let* (optvars optinits optsuppliedp)
1649        (until (eq opttail resttail) 
1650          (setq sym (pop opttail))
1651          (let* ((var sym)
1652                 (initform nil)
1653                 (spvar nil))
1654            (when (consp var)
1655              (setq sym (pop var) initform (pop var) spvar (%car var)))
1656            (push (if no-acode initform (nx1-form initform)) optinits)
1657            (push (if (symbolp sym)
1658                          (nx-new-structured-var pending sym)
1659                          (nx-structured-lambda-form pending sym no-acode))
1660                        optvars)
1661            (push (if spvar (nx-new-var pending spvar)) optsuppliedp)))
1662        (if optvars
1663          (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
1664          (nx1-whine :lambda ll))))
1665    (let ((var (pop resttail)))
1666      (when (or (eq var '&rest)
1667                (eq var '&body))
1668        (setq var (pop resttail)
1669              rest (if (symbolp var)
1670                     (nx-new-structured-var pending var)
1671                     (nx-structured-lambda-form pending var no-acode)))))
1672    (when (eq (%car keytail) '&key) 
1673      (setq keytail (%cdr keytail))
1674      (let* ((keysyms ())
1675             (keykeys ())
1676             (keyinits ())
1677             (keysupp ())
1678             (kallowother (not (null (memq '&allow-other-keys ll))))
1679             (kvar ())
1680             (kkey ())
1681             (kinit ())
1682             (ksupp))
1683        (until (eq keytail auxtail)
1684          (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
1685            (setq kinit *nx-nil* ksupp nil)
1686            (if (atom sym)
1687              (setq kvar sym kkey (make-keyword sym))
1688              (progn
1689                (if (consp (%car sym))
1690                  (setq kkey (%caar sym) kvar (%cadar sym))
1691                  (progn
1692                    (setq kvar (%car sym))
1693                    (setq kkey (make-keyword kvar))))
1694                (setq kinit (if no-acode (%cadr sym) (nx1-form (%cadr sym))))
1695                (setq ksupp (%caddr sym))))
1696            (push (if (symbolp kvar)
1697                          (nx-new-structured-var pending kvar)
1698                          (nx-structured-lambda-form pending kvar no-acode))
1699                        keysyms)
1700            (push kkey keykeys)
1701            (push kinit keyinits)
1702            (push (if ksupp (nx-new-var pending ksupp)) keysupp)))
1703        (setq 
1704         keys
1705         (list
1706          kallowother
1707          (nreverse keysyms)
1708          (nreverse keysupp)
1709          (nreverse keyinits)
1710          (apply #'vector (nreverse keykeys))))))
1711    (let (auxvals auxvars)
1712      (dolist (pair (%cdr auxtail))
1713        (let ((auxvar (nx-pair-name pair))
1714              (auxval (nx-pair-initform pair)))
1715          (push (if no-acode auxval (nx1-form auxval)) auxvals)
1716          (push (nx-new-var pending auxvar) auxvars)))
1717      (values
1718       (nreverse req) 
1719       opt 
1720       rest 
1721       keys
1722       (list (nreverse auxvars) (nreverse auxvals))
1723       whole))))
1724
1725(defun nx-structured-lambda-form (pending l &optional no-acode)
1726  (multiple-value-bind (req opt rest keys auxen whole)
1727                       (nx-parse-structured-lambda-list pending l no-acode t)
1728    (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
1729
1730(defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*))
1731  (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the))
1732                           (nx-target-type (cadr form))
1733                           t)))
1734    (nx1-typed-form form *nx-lexical-environment*)))
1735
1736(defun nx1-typed-form (original env)
1737  (with-program-error-handler
1738      (lambda (c)
1739        (let ((replacement (runtime-program-error-form c)))
1740          (nx-note-source-transformation original replacement)
1741          (nx1-transformed-form (nx-transform replacement env) env)))
1742    (multiple-value-bind (form changed source) (nx-transform original env)
1743      (declare (ignore changed))
1744      ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from.
1745      (let ((*nx-current-note* (or source *nx-current-note*)))
1746        (nx1-transformed-form form env)))))
1747
1748(defun nx1-transformed-form (form env)
1749  (let* ((*nx-current-note* (or (nx-source-note form) *nx-current-note*))
1750         (*nx-current-code-note*  (and *nx-current-code-note*
1751                                       (or (nx-ensure-code-note form *nx-current-code-note*)
1752                                           (compiler-bug "No source note for ~s" form))))
1753         (acode (if (consp form)
1754                  (nx1-combination form env)
1755                  (let* ((symbolp (non-nil-symbol-p form))
1756                         (constant-value (unless symbolp form))
1757                         (constant-symbol-p nil))
1758                    (if symbolp 
1759                      (multiple-value-setq (constant-value constant-symbol-p) 
1760                        (nx-transform-defined-constant form env)))
1761                    (if (and symbolp (not constant-symbol-p))
1762                      (nx1-symbol form env)
1763                      (nx1-immediate (nx-unquote constant-value)))))))
1764    (unless (acode-note acode) ;; leave it with most specific note
1765      (cond (*nx-current-code-note*
1766             (setf (acode-note acode) *nx-current-code-note*))
1767            (*record-pc-mapping*
1768             (setf (acode-note acode) (nx-source-note form)))))
1769    acode))
1770
1771(defun nx1-prefer-areg (form env)
1772  (nx1-form form env))
1773
1774(defun nx1-target-fixnump (form)
1775  (when (typep form 'integer)
1776    (let* ((target (backend-target-arch *target-backend*)))
1777      (and
1778       (>= form (arch::target-most-negative-fixnum target))
1779       (<= form (arch::target-most-positive-fixnum target))))))
1780
1781
1782(defun nx1-immediate (form)
1783  #+notyet
1784  (cond ((eq form t) (make-acode (%nx1-operator t)))
1785        ((null form) (make-acode (%nx1-operator nil)))
1786        ((nx1-target-fixnump form)
1787         (make-acode (%nx1-operator fixnum) form))
1788        (t (make-acode (%nx1-operator immediate) form)))
1789  #-notyet
1790  (if (or (eq form t) (null form))
1791    (nx1-sysnode form)
1792    (make-acode
1793     (if (nx1-target-fixnump form) 
1794       (%nx1-operator fixnum)
1795       (%nx1-operator immediate))   ; Screw: chars
1796     form)))
1797
1798(defun nx2-constant-form-value (form)
1799  (setq form (nx-untyped-form form))
1800  (and (or (nx-null form)
1801           (nx-t form)
1802           (and (acode-p form)
1803                (or (eq (acode-operator form) (%nx1-operator immediate))
1804                    (eq (acode-operator form) (%nx1-operator fixnum))
1805                    (eq (acode-operator form) (%nx1-operator simple-function)))))
1806       form))
1807
1808(defun nx-natural-constant-p (form)
1809  (setq form (nx-untyped-form form))
1810  (if (consp form)
1811    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1812                        (eq (acode-operator form) (%nx1-operator immediate)))
1813                  (cadr form))))
1814      (and (typep val *nx-target-natural-type*) val))))
1815
1816(defun nx-u32-constant-p (form)
1817  (setq form (nx-untyped-form form))
1818  (if (consp form)
1819    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1820                        (eq (acode-operator form) (%nx1-operator immediate)))
1821                  (cadr form))))
1822      (and (typep val '(unsigned-byte 32)) val))))
1823
1824(defun nx-u31-constant-p (form)
1825  (setq form (nx-untyped-form form))
1826  (if (consp form)
1827    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1828                        (eq (acode-operator form) (%nx1-operator immediate)))
1829                  (cadr form))))
1830      (and (typep val '(unsigned-byte 31)) val))))
1831
1832
1833;;; Reference-count vcell, fcell refs.
1834(defun nx1-note-vcell-ref (sym)
1835  (let* ((there (assq sym *nx1-vcells*))
1836         (count (expt 4 *nx-loop-nesting-level*)))
1837    (if there
1838      (%rplacd there (%i+ (%cdr there) count))
1839      (push (cons sym count) *nx1-vcells*)))
1840  sym)
1841
1842(defun nx1-note-fcell-ref (sym)
1843  (let* ((there (assq sym *nx1-fcells*))
1844         (count (expt 4 *nx-loop-nesting-level*)))
1845    (if there
1846      (%rplacd there (%i+ (%cdr there) count))
1847      (push (cons sym count) *nx1-fcells*))
1848    sym))
1849
1850; Note that "simple lexical refs" may not be; that's the whole problem ...
1851(defun nx1-symbol (form &optional (env *nx-lexical-environment*))
1852  (let* ((type (nx-declared-type form))
1853         (form
1854          (multiple-value-bind (info inherited-p more)
1855                               (nx-lex-info form)
1856            (if (and info (neq info :special))
1857              (if (eq info :symbol-macro)
1858                (progn
1859                  (nx-set-var-bits more (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits more)))
1860                  (if (eq type t)
1861                    (nx1-form inherited-p)
1862                    (nx1-form `(the ,(prog1 type (setq type t)) ,inherited-p))))
1863                (progn
1864                  (when (not inherited-p)
1865                    (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info))))
1866                  (nx-adjust-ref-count info)
1867                  (nx-make-lexical-reference info)))
1868              (make-acode
1869               (if (nx1-check-special-ref form info)
1870                   (progn
1871                     (nx-record-xref-info :references form)
1872                     (if (nx-global-p form env)
1873                         (%nx1-operator global-ref)
1874                         (if (and (not (nx-force-boundp-checks form env))
1875                                  (or (nx-proclaimed-parameter-p form)
1876                                  (assq form *nx-compile-time-types*)
1877                                  (assq form *nx-proclaimed-types*)
1878                                  (nx-open-code-in-line env)))
1879                             (%nx1-operator bound-special-ref)
1880                             (%nx1-operator special-ref))))
1881                   (%nx1-operator free-reference))
1882               (nx1-note-vcell-ref form))))))
1883    (if (eq type t)
1884        form
1885      (make-acode (%nx1-operator typed-form) type form))))
1886
1887(defun nx1-check-special-ref (form auxinfo)
1888  (or (eq auxinfo :special) 
1889      (nx-proclaimed-special-p form)
1890      (let ((defenv (definition-environment *nx-lexical-environment*)))
1891        (unless (and defenv (eq (car (defenv.type defenv)) :execute) (boundp form))
1892          (nx1-whine :special form))
1893        nil)))
1894
1895
1896
1897(defun nx1-whine (about &rest forms)
1898  (push (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
1899                        :function-name (list *nx-cur-func-name*)
1900                        :source-note *nx-current-note*
1901                        :warning-type about
1902                        :args (or forms (list nil)))
1903        *nx-warnings*))
1904
1905(defun p2-whine (afunc about &rest forms)
1906  (let* ((warning (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
1907                                  :function-name (list (afunc-name afunc))
1908                                  :warning-type about
1909                                  :args (or forms (list nil)))))
1910    (push warning (afunc-warnings afunc))
1911    (do* ((p (afunc-parent afunc) (afunc-parent p)))
1912         ((null p) warning)
1913      (let* ((pname (afunc-name p)))
1914        (push pname (compiler-warning-function-name warning))
1915        (push warning (afunc-warnings p))))))
1916
1917(defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*))
1918  (let* ((ctype1 (if (typep type1 'ctype) type1 (values-specifier-type type1 env)))
1919         (ctype2 (if (typep type2 'ctype) type2 (values-specifier-type type2 env)))
1920         (intersection (if (or (values-ctype-p ctype1) (values-ctype-p ctype2))
1921                         (values-type-intersection ctype1 ctype2)
1922                         (type-intersection ctype1 ctype2))))
1923    (when (eq intersection *empty-type*)
1924      (let ((type1 (if (typep type1 'ctype)
1925                     (type-specifier type1)
1926                     type1))
1927            (type2 (if (typep type2 'ctype)
1928                     (type-specifier type2)
1929                     type2)))
1930        (nx1-whine :type-conflict form type1 type2)))
1931    (type-specifier intersection)))
1932
1933(defun nx-declared-notinline-p (sym env)
1934  (setq sym (maybe-setf-function-name sym))
1935  (loop
1936    (when (listp env)
1937      (return (and (symbolp sym)
1938                   (proclaimed-notinline-p sym))))
1939    (dolist (decl (lexenv.fdecls env))
1940      (when (and (eq (car decl) sym)
1941                 (eq (cadr decl) 'inline))
1942         (return-from nx-declared-notinline-p (eq (cddr decl) 'notinline))))
1943    (setq env (lexenv.parent-env env))))
1944
1945
1946
1947(defun nx1-combination (form env)
1948  (destructuring-bind (sym &rest args) form
1949    (if (symbolp sym)
1950      (let* ((*nx-sfname* sym) special)
1951        (if (and (setq special (gethash sym *nx1-alphatizers*))
1952                 (or (not (functionp (fboundp sym)))
1953                     (memq sym '(apply funcall ;; see bug #285
1954                                 %defun        ;; see bug #295
1955                                 ))
1956                     (< (safety-optimize-quantity env) 3))
1957                 ;;(not (nx-lexical-finfo sym env))
1958                 (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
1959          (funcall special form env) ; pass environment arg ...
1960          (progn           
1961            (nx1-typed-call sym args))))
1962      (if (lambda-expression-p sym)
1963        (nx1-lambda-bind (%cadr sym) args (%cddr sym))
1964        (nx-error "In the form ~S, ~S is not a symbol or lambda expression." form sym)))))
1965
1966(defun nx1-treat-as-call (args)
1967  (nx1-typed-call (car args) (%cdr args)))
1968
1969(defun nx1-typed-call (fn args &optional spread-p)
1970  (let ((global-only nil)
1971        (errors-p nil)
1972        (result-type t))
1973    (when (and (acode-p fn) (eq (acode-operator fn) (%nx1-operator immediate)))
1974      (multiple-value-bind (valid name) (valid-function-name-p (%cadr fn))
1975        (when valid
1976          (setq fn name global-only t))))
1977    (when (non-nil-symbol-p fn)
1978      (multiple-value-setq (errors-p args result-type)
1979        (nx1-check-typed-call fn args spread-p global-only)))
1980    (setq result-type (nx1-type-intersect fn *nx-form-type* result-type))
1981    (let ((form (nx1-call fn args spread-p global-only errors-p)))
1982      (if (eq result-type t)
1983        form
1984        (make-acode (%nx1-operator typed-form) result-type form)))))
1985
1986(defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0)
1987                                 (y-or-n-p . 0) (yes-or-no-p . 0)
1988                                 (signal-simple-program-error . 0)
1989                                 (signal-simple-condition . 1)
1990                                 (signal-reader-error . 1)
1991                                 (%method-combination-error . 0)
1992                                 (%invalid-method-error . 1)
1993                                 (nx-compile-time-error . 0)
1994                                 (nx-error . 0)
1995                                 (compiler-bug . 0)))
1996
1997(defun nx1-find-call-def (sym &optional (env *nx-lexical-environment*) (global-only nil))
1998  (and (or (and (not global-only) (nth-value 1 (nx-lexical-finfo sym)))
1999           (retrieve-environment-function-info sym env)
2000           (let ((def (fboundp sym)))
2001             (and (functionp def) def)))))
2002
2003(defun nx1-check-typed-call (sym args &optional spread-p global-only)
2004  (let ((env *nx-lexical-environment*)
2005        (result-type t)
2006        (typed-args args)
2007        (errors-p nil)
2008        (ftype nil)
2009        (def nil))
2010    (setq ftype (find-ftype-decl sym env args spread-p))
2011    (setq def (nx1-find-call-def sym env global-only))
2012    (when ftype
2013      (multiple-value-setq (typed-args result-type errors-p)
2014        (nx1-analyze-ftyped-call ftype sym args spread-p env)))
2015    (when (and def (not errors-p))
2016      (multiple-value-bind (deftype reason) (nx1-check-call-args def args spread-p)
2017        (when deftype
2018          (nx1-whine deftype sym reason args spread-p)
2019          (setq errors-p t))))
2020    (unless (or def ftype (eq sym *nx-global-function-name*))
2021      (nx1-whine :undefined-function sym args spread-p)
2022      (setq errors-p t))
2023    (unless errors-p
2024      (let* ((format-args (and (not spread-p)
2025                               (not (typep def 'afunc))
2026                               (let* ((n (cdr (assq sym *format-arg-functions*))))
2027                                 (and n (nthcdr n typed-args)))))
2028             (control (pop format-args)))
2029        (when (and (consp control)
2030                   (eq (%car control) 'the)
2031                   (consp (%cdr control))
2032                   (consp (%cddr control)))
2033          (setq control (%caddr control)))
2034        (when (stringp (setq control (nx-transform control env)))
2035          (when (nx1-check-format-call control format-args env)
2036            (setq errors-p t)))))
2037
2038    (values errors-p typed-args result-type)))
2039
2040(defun known-ftype-for-call (sym args spread-p env)
2041  ;; Find ftype based on actual arguments.
2042  ;; This should be more general, but for now just pick off some special cases..
2043  (when (and args (or (not spread-p) (cdr args)))
2044    (cond ((or (eq sym 'aref) (eq sym 'uvref))
2045           (let* ((atype (nx-form-type (car args) env))
2046                  (a-ctype (specifier-type atype)))
2047             (when (array-ctype-p a-ctype)
2048               ;; No point declaring the type of an arg whose type we already know
2049               `(function (t &rest integer) ,(type-specifier (array-ctype-specialized-element-type
2050                                                                  a-ctype))))))
2051          ((eq sym 'error)
2052           (let ((condition (car args)))
2053             (cond ((nx-form-typep condition 'condition env)
2054                    '(function (t) *))
2055                   ((nx-form-typep condition 'symbol env)
2056                    ;; TODO: might be able to figure out actual initargs...
2057                    `(function (t &key &allow-other-keys) *))
2058                   (t nil))))
2059          ((eq sym 'cerror)
2060           (when (and (cdr args) (or (not spread-p) (cddr args)))
2061             (let ((condition (cadr args)))
2062               (cond ((nx-form-typep condition 'condition env)
2063                      `(function (string t &rest t) *))
2064                     ((nx-form-typep condition 'symbol env)
2065                      `(function (string t &key &allow-other-keys) *))
2066                     (t `(function (string t &rest t) *))))))
2067          (t nil))))
2068
2069(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*) (args :unknown) spread-p)
2070  (setq sym (maybe-setf-function-name sym))
2071  (loop
2072    for lexenv = env then (lexenv.parent-env lexenv) until (listp lexenv)
2073    do (dolist (fdecl (lexenv.fdecls lexenv))
2074         (when (and (eq (car fdecl) sym)
2075                    (eq (car (%cdr fdecl)) 'ftype))
2076           (return-from find-ftype-decl (%cddr fdecl))))
2077    do (when (and (istruct-typep lexenv 'lexical-environment)
2078                  (assq sym (lexenv.functions lexenv)))
2079         (return-from find-ftype-decl nil)))
2080  (or (proclaimed-ftype sym)
2081      (and (listp args)
2082           (known-ftype-for-call sym args spread-p env))))
2083
2084(defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env)
2085  (let ((ctype (if (typep ftype 'ctype) ftype (specifier-type ftype)))
2086        (result-type t)
2087        (errors-p nil))
2088    (unless (or (null ctype) (not (function-ctype-p ctype)))
2089      (unless (function-ctype-wild-args ctype)
2090        (let ((req (args-ctype-required ctype))
2091              (opt (args-ctype-optional ctype))
2092              (rest (args-ctype-rest ctype))
2093              (keyp (args-ctype-keyp ctype))
2094              (aokp (or spread-p (args-ctype-allowp ctype)))
2095              (keys (args-ctype-keywords ctype))
2096              (typed-arglist nil)
2097              (key-type nil)
2098              (bad-keys nil)
2099              (nargs (if spread-p (1- (length arglist)) (length arglist))))
2100          (flet ((collect-type (arg type)
2101                   (push (if (and type
2102                                  (neq type *universal-type*)
2103                                  (neq type *wild-type*)
2104                                  (setq type (type-specifier type))
2105                                  ;; Don't record unknown types, just causes spurious warnings.
2106                                  (specifier-type-if-known type env :values t))
2107                             `(the ,type ,arg)
2108                             arg)
2109                         typed-arglist))
2110                 (key-name (x) (key-info-name x))
2111                 (whine (&rest reason)
2112                   (nx1-whine :ftype-mismatch sym reason arglist spread-p)
2113                   (setq errors-p t)))
2114            (declare (dynamic-extent #'collect-type #'whine))
2115            (loop for arg in arglist as i below nargs
2116                  do (cond
2117                       (req (collect-type arg (pop req)))
2118                       (opt (collect-type arg (pop opt)))
2119                       (rest (collect-type arg rest))
2120                       (key-type (collect-type arg (shiftf key-type nil)))
2121                       (keyp (if (nx-form-constant-p arg env)
2122                               (let* ((key (nx-form-constant-value arg env))
2123                                      (ki (find key keys :key #'key-name)))
2124                                 (when (eq key :allow-other-keys) (setq aokp t))
2125                                 (if ki
2126                                   (setq key-type (key-info-type ki))
2127                                   (unless aokp (push key bad-keys))))
2128                               (setq aokp t))
2129                             (collect-type arg nil)
2130                             (unless key-type (setq key-type *universal-type*)))
2131                       (t (return (whine :toomany
2132                                         nargs
2133                                         (+ (length (args-ctype-required ctype))
2134                                            (length (args-ctype-optional ctype)))))))
2135                  finally (cond (spread-p (collect-type arg nil))
2136                                (req (whine :toofew
2137                                            nargs
2138                                            (length (args-ctype-required ctype))))
2139                                (key-type (whine :odd-keywords 
2140                                                 (nthcdr
2141                                                  (+ (length (args-ctype-required ctype))
2142                                                     (length (args-ctype-optional ctype)))
2143                                                  arglist)))
2144                                (bad-keys (whine :unknown-keyword
2145                                                 (if (cdr bad-keys)
2146                                                   (nreverse bad-keys)
2147                                                   (car bad-keys))
2148                                                 (map 'list #'key-name keys)))))
2149            (unless errors-p
2150              (setq arglist (nreverse typed-arglist))))))
2151      (setq result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
2152    (values arglist (nx-target-type result-type) errors-p)))
2153
2154
2155(defun innermost-lfun-bits-keyvect (def)
2156  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
2157         (bits (lfun-bits inner-def))
2158         (keys (lfun-keyvect inner-def)))
2159    (declare (fixnum bits))
2160    #+no
2161    (when (and (eq (ash 1 $lfbits-gfn-bit)
2162                   (logand bits (logior (ash 1 $lfbits-gfn-bit)
2163                                        (ash 1 $lfbits-method-bit))))
2164               (logbitp $lfbits-keys-bit bits))
2165      (setq bits (logior (ash 1 $lfbits-aok-bit) bits)
2166            keys nil))
2167    (values bits keys)))
2168
2169(defun def-info-bits-keyvect (info)
2170  (let ((bits (def-info.lfbits info)))
2171    (when (and (eq (def-info.function-type info) 'defgeneric)
2172               (logbitp $lfbits-keys-bit bits)
2173               (not (logbitp $lfbits-aok-bit bits))
2174               #-BOOTSTRAPPED (fboundp 'def-info-method.keyvect)
2175               (loop for m in (def-info.methods info)
2176                     thereis (null (def-info-method.keyvect m))))
2177      ;; Some method has &aok, don't bother checking keywords.
2178      (setq bits (logior bits (ash 1 $lfbits-aok-bit))))
2179    (values bits (def-info.keyvect info))))
2180
2181
2182(defun nx1-check-call-args (def arglist spread-p)
2183  (multiple-value-bind (bits keyvect)
2184      (etypecase def
2185        (function (innermost-lfun-bits-keyvect def))
2186        (afunc (let ((lambda-form (afunc-lambdaform def)))
2187                 (and (lambda-expression-p lambda-form)
2188                      (encode-lambda-list (cadr lambda-form) t))))
2189        (cons (def-info-bits-keyvect (cdr def))))
2190    (when bits
2191      (multiple-value-bind (reason defer-p)
2192          (or (nx1-check-call-bits bits arglist spread-p) ;; never deferred
2193              (nx1-check-call-keywords def bits keyvect arglist spread-p))
2194        (when reason
2195          #-BOOTSTRAPPED (unless (find-class 'undefined-keyword-reference nil)
2196                           (return-from nx1-check-call-args nil))
2197          (values (if defer-p
2198                    :deferred-mismatch
2199                    (typecase def
2200                      (function :global-mismatch)
2201                      (afunc :lexical-mismatch)
2202                      (t :environment-mismatch)))
2203                  reason))))))
2204
2205(defun nx1-check-call-bits (bits arglist spread-p)
2206  (let* ((nargs (length arglist))
2207         (minargs (if spread-p (1- nargs) nargs))
2208         (required (ldb $lfbits-numreq bits))
2209         (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
2210                nil
2211                (+ required (ldb $lfbits-numopt bits)))))
2212    ;; If the (apparent) number of args in the call doesn't
2213    ;; match the definition, complain.  If "spread-p" is true,
2214    ;; we can only be sure of the case when more than the
2215    ;; required number of args have been supplied.
2216    (or (and (not spread-p)
2217             (< minargs required)
2218             `(:toofew ,minargs ,required))
2219        (and max
2220             (> minargs max)
2221             `(:toomany ,nargs ,max)))))
2222
2223(defun nx1-check-call-keywords (def bits keyvect args spread-p &aux (env *nx-lexical-environment*))
2224  ;; Ok, if generic function, bits and keyvect are for the generic function itself.
2225  ;; Still, since all congruent, can check whether have variable numargs
2226  (unless (and (logbitp $lfbits-keys-bit bits)
2227               (not spread-p)) ; last argform may contain :allow-other-keys
2228    (return-from nx1-check-call-keywords nil))
2229  (let* ((bad-keys nil)
2230         (key-args (nthcdr (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)) args))
2231         (generic-p (or (generic-function-p def)
2232                        (and (consp def)
2233                             (eq (def-info.function-type (cdr def)) 'defgeneric)))))
2234    (when (oddp (length key-args))
2235      (return-from nx1-check-call-keywords (list :odd-keywords key-args)))
2236    (when (logbitp $lfbits-aok-bit bits)
2237      (return-from nx1-check-call-keywords nil))
2238    (loop for key-form in key-args by #'cddr
2239          do (unless (nx-form-constant-p key-form env) ;; could be :aok
2240               (return-from nx1-check-call-keywords nil))
2241          do (let ((key (nx-form-constant-value key-form env)))
2242               (when (eq key :allow-other-keys)
2243                 (return-from nx1-check-call-keywords nil))
2244               (unless (or (find key keyvect)
2245                          (and generic-p (nx1-valid-gf-keyword-p def key)))
2246                 (push key bad-keys))))
2247    (when bad-keys
2248      (if generic-p
2249        (values (list :unknown-gf-keywords bad-keys) t)
2250        (list :unknown-keyword (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys)) keyvect)))))
2251
2252(defun nx1-valid-gf-keyword-p (def key)
2253  ;; Can assume has $lfbits-keys-bit and not $lfbits-aok-bit
2254  (if (consp def)
2255    (let ((definfo (cdr def)))
2256      (assert (eq (def-info.function-type definfo) 'defgeneric))
2257      (loop for m in (def-info.methods definfo)
2258            as keyvect = (def-info-method.keyvect m)
2259            thereis (or (null keyvect) (find key keyvect))))
2260    (let ((gf (find-unencapsulated-definition def)))
2261      (or (find key (%defgeneric-keys gf))
2262          (loop for m in (%gf-methods gf)
2263                thereis (let* ((func (%inner-method-function m))
2264                               (mbits (lfun-bits func)))
2265                          (or (and (logbitp $lfbits-aok-bit mbits)
2266                                   ;; If no &rest, then either don't use the keyword in which case
2267                                   ;; it's good to warn; or it's used via next-method, we'll approve
2268                                   ;; it when we get to that method.
2269                                   (logbitp $lfbits-rest-bit mbits))
2270                              (find key (lfun-keyvect func)))))))))
2271
2272;;; we can save some space by going through subprims to call "builtin"
2273;;; functions for us.
2274(defun nx1-builtin-function-offset (name)
2275   (arch::builtin-function-name-offset name))
2276
2277(defun nx1-call-form (global-name afunc arglist spread-p  &optional (env *nx-lexical-environment*))
2278  (if afunc
2279    (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p)
2280    (let* ((builtin (unless (or spread-p
2281                                (eql 3 (safety-optimize-quantity env)))
2282                      (nx1-builtin-function-offset global-name))))
2283      (if (and builtin
2284               (let* ((bits (lfun-bits (fboundp global-name))))
2285                 (and bits (eql (logand $lfbits-args-mask bits)
2286                                (dpb (length arglist)
2287                                     $lfbits-numreq
2288                                     0)))))
2289        (make-acode (%nx1-operator builtin-call) 
2290                    (make-acode (%nx1-operator fixnum) builtin)
2291                    (nx1-arglist arglist))
2292        (make-acode (%nx1-operator call)
2293                     (if (symbolp global-name)
2294                       (nx1-immediate (nx1-note-fcell-ref global-name))
2295                       global-name)
2296                     (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*)))
2297                     spread-p)))))
2298 
2299;;; If "sym" is an expression (not a symbol which names a function),
2300;;; the caller has already alphatized it.
2301(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
2302  (nx1-verify-length args 0 nil)
2303  (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
2304    (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
2305      (when valid
2306        (setq global-only t sym name))))
2307  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
2308    (if (nx-self-call-p sym global-only)
2309      ;; Should check for downward functions here as well.
2310      (multiple-value-bind (deftype reason)
2311                           (nx1-check-call-args *nx-current-function* args spread-p)
2312        (when deftype
2313          (nx1-whine deftype sym reason args spread-p))
2314        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
2315      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
2316        (or (and (not inhibit-inline)
2317                 (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*))
2318            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
2319              (when (eq 'macro (car info))
2320                (nx-error "Can't call macro function ~s" sym))
2321              (nx-record-xref-info :direct-calls sym)
2322              (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc)))
2323                (let ((sym (var-name (afunc-lfun afunc))))
2324                  (nx1-form 
2325                   (if spread-p
2326                     `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
2327                     `(funcall ,sym ,@args))))
2328                (let* ((val (nx1-call-form sym afunc args spread-p)))
2329                    (when afunc
2330                      (let ((callers (afunc-callers afunc))
2331                            (self *nx-current-function*))
2332                        (unless (or (eq self afunc) (memq self callers))
2333                          (setf (afunc-callers afunc) (cons self callers)))))
2334                    (if (and (null afunc) (memq sym *nx-never-tail-call*))
2335                      (make-acode (%nx1-operator values) (list val))
2336                      val)))))))))
2337
2338(defun nx1-expand-inline-call (lambda-form env token args spread-p old-env)
2339  (if (and (or (null spread-p) (eq (length args) 1)))
2340    (if (and token (not (memq token *nx-inline-expansions*)))
2341      (with-program-error-handler (lambda (c) (declare (ignore c)) nil)
2342        (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
2343               (lambda-list (cadr lambda-form))
2344               (body (cddr lambda-form))
2345               (new-env (new-lexical-environment env)))
2346          (setf (lexenv.mdecls new-env)
2347                `((speed . ,(speed-optimize-quantity old-env))
2348                  (space . ,(space-optimize-quantity old-env))
2349                  (safety . ,(space-optimize-quantity old-env))
2350                  (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
2351                  (debug . ,(debug-optimize-quantity old-env))))
2352          (if spread-p
2353            (nx1-destructure lambda-list (car args) nil nil body new-env)
2354            (nx1-lambda-bind lambda-list args body new-env)))))))
2355             
2356; note that regforms are reversed: arg_z is always in the car
2357(defun nx1-arglist (args &optional (nregargs (backend-num-arg-regs *target-backend*)))
2358  (declare (fixnum nregargs))
2359  (let* ((stkforms nil)
2360         (regforms nil)
2361         (nstkargs (%i- (length args) nregargs)))
2362    (declare (fixnum nstkargs))
2363      (list
2364       (dotimes (i nstkargs (nreverse stkforms))
2365         (declare (fixnum i))
2366         (push (nx1-form (%car args)) stkforms)
2367         (setq args (%cdr args)))
2368       (dolist (arg args regforms)
2369         (push (nx1-form arg) regforms)))))
2370
2371(defun nx1-formlist (args)
2372  (let* ((a nil))
2373    (dolist (arg args)
2374      (push (nx1-form arg) a))
2375    (nreverse a)))
2376
2377(defun nx1-verify-length (forms min max &aux (len (list-length forms)))
2378 (if (or (null len)
2379         (%i> min len)
2380         (and max (%i> len max)))
2381     (nx-error "Wrong number of args in form ~S." (cons *nx-sfname* forms))
2382     len))
2383
2384(defun nx-unquote (form)
2385  (if (nx-quoted-form-p form)
2386    (%cadr form)
2387    form))
2388
2389(defun nx-quoted-form-p (form &aux (f form))
2390 (and (consp form)
2391      (eq (pop form) 'quote)
2392      (or
2393       (and (consp form)
2394            (not (%cdr form)))
2395       (nx-error "Illegally quoted form ~S." f))))
2396
2397(defun nx-form-constant-p (form env)
2398  (declare (ignore env))
2399  (or (quoted-form-p form)
2400      (self-evaluating-p form)))
2401
2402(defun nx-form-constant-value (form env)
2403  (declare (ignore env))
2404  (declare (type (satisfies nx-form-constant-p) form))
2405  (if (consp form) (%cadr form) form))
2406
2407; Returns two values: expansion & win
2408; win is true if expansion is not EQ to form.
2409; This is a bootstrapping version.
2410; The real one is in "ccl:compiler;optimizers.lisp".
2411(unless (fboundp 'maybe-optimize-slot-accessor-form)
2412
2413(defun maybe-optimize-slot-accessor-form (form environment)
2414  (declare (ignore environment))
2415  (values form nil))
2416
2417)
2418
2419(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
2420  (when source-notes
2421    (when (or (consp form) (vectorp form) (pathnamep form))
2422      (let ((note (gethash form source-notes)))
2423        (unless (listp note) note)))))
2424
2425
2426(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
2427  (macrolet ((form-changed (form)
2428               `(progn
2429                  (unless source (setq source (gethash ,form source-note-map)))
2430                  (setq changed t))))
2431    (prog (sym transforms lexdefs changed enabled macro-function compiler-macro (source t))
2432       (when source-note-map
2433         (setq source (gethash form source-note-map)))
2434       (go START)
2435     LOOP
2436       (form-changed form)
2437       (when (and (consp form) 
2438                  (or (eq (%car form) 'the)
2439                      (and sym (eq (%car form) sym))))
2440         (go DONE))
2441     START
2442       (when (non-nil-symbol-p form)
2443         (multiple-value-bind (newform win) (nx-transform-symbol form environment)
2444           (unless win (go DONE))
2445           (setq form newform)
2446           (go LOOP)))
2447       (when (atom form) (go DONE))
2448       (unless (symbolp (setq sym (%car form)))
2449         (go DONE))
2450       #+no
2451       (when (eq sym 'the)
2452         (destructuring-bind (typespec thing) (cdr form)
2453           (if (constantp thing)
2454             (progn
2455               (setq form thing)
2456               (go LOOP))
2457             (multiple-value-bind (newform win) (nx-transform thing environment source-note-map)
2458               (when win
2459                 (form-changed newform)
2460                 (if (and (self-evaluating-p newform)
2461                          (typep newform typespec))
2462                   (setq form newform)
2463                   (setq form `(the ,typespec ,newform)))
2464                 (go DONE))))))
2465       (when (nx-quoted-form-p form)
2466         (when (self-evaluating-p (%cadr form))
2467           (setq form (%cadr form)))
2468         (go DONE))
2469       (when (setq lexdefs (nx-lexical-finfo sym environment))
2470         (if (eq 'function (%car lexdefs))
2471           (go DONE)))
2472       (setq transforms (setq compiler-macro (compiler-macro-function sym environment))
2473             macro-function (macro-function sym environment)
2474             enabled (nx-allow-transforms environment))
2475       (unless macro-function
2476         (let* ((win nil))
2477           (when (and enabled (functionp (fboundp sym)))
2478             (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map))
2479             (when win
2480               (form-changed form)))))
2481       (when (and enabled
2482                  (not (nx-declared-notinline-p sym environment)))
2483         (multiple-value-bind (value folded) (nx-constant-fold form environment)
2484           (when folded
2485             (setq form value)
2486             (form-changed form)
2487             (unless (and (consp form) (eq (car form) sym)) (go START))))
2488         (when compiler-macro
2489           (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
2490             (when win
2491               (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym)))
2492                 (setq sym nil))
2493               (setq form newform)
2494               (go LOOP))))
2495         (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment)
2496           (when win
2497             (setq sym nil)
2498             (setq form newform)
2499             (go START)))
2500         (unless macro-function
2501           (when (setq transforms (structref-info sym environment))
2502             (setq form (defstruct-ref-transform transforms (%cdr form) environment))
2503             (form-changed form)
2504             (go START))
2505           (when (setq transforms (assq sym *nx-synonyms*))
2506             (setq form (cons (%cdr transforms) (setq sym (%cdr form))))
2507             (go LOOP))))
2508       (when (and macro-function
2509                  (or lexdefs
2510                      (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment))))))
2511         (nx-record-xref-info :macro-calls (function-name macro-function))
2512         (setq form (macroexpand-1 form environment))
2513         (form-changed form)
2514         (go START))
2515     DONE
2516       (if (eq source t)
2517         (setq source nil)
2518         (let ((this (nx-source-note form)))
2519           (if this
2520             (setq source this)
2521             (when source
2522               (unless (and (consp form)
2523                            (eq (%car form) 'the)
2524                            (eq source (gethash (caddr form) source-note-map)))
2525                 (when (or (consp form) (vectorp form) (pathnamep form))
2526                   (unless (or (eq form (%unbound-marker))
2527                               (eq form (%slot-unbound-marker)))
2528                     (setf (gethash form source-note-map) source))))))))
2529       ;; Return source for symbols, even though don't record it in hash table.
2530       (return (values form changed source)))))
2531
2532
2533; Transform all of the arguments to the function call form.
2534; If any of them won, return a new call form (with the same operator as the original), else return the original
2535; call form unchanged.
2536(defun nx-transform-arglist (callform env source-note-map)
2537  (let* ((any-wins nil)
2538         (transformed-call (cons (car callform) nil))
2539         (ptr transformed-call)
2540         (win nil))
2541    (declare (type cons ptr))
2542    (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
2543      (multiple-value-setq (form win) (nx-transform form env source-note-map))
2544      (rplacd ptr (setq ptr (cons form nil)))
2545      (if win (setq any-wins t)))))
2546
2547;This is needed by (at least) SETF.
2548(defun nxenv-local-function-p (name macro-env)
2549  (multiple-value-bind (type local-p) (function-information name macro-env)
2550    (and local-p (eq :function type))))
2551
2552           
2553;;; This guy has to return multiple values.  The arguments have
2554;;; already been transformed; if they're all constant (or quoted), try
2555;;; to evaluate the expression at compile-time.
2556(defun nx-constant-fold (original-call &optional (environment *nx-lexical-environment*) &aux 
2557                                       (fn (car original-call)) form mv foldable foldfn)
2558  (flet ((quotify (x) (if (self-evaluating-p x) x (list 'quote x))))
2559    (if (and (nx-allow-transforms environment)
2560             (let* ((bits (if (symbolp fn) (%symbol-bits fn) 0)))
2561               (declare (fixnum bits))
2562               (if (setq foldable (logbitp $sym_fbit_constant_fold bits))
2563                 (if (logbitp $sym_fbit_fold_subforms bits)
2564                   (setq foldfn 'fold-constant-subforms))
2565                 (setq foldable (assq fn *nx-can-constant-fold*)
2566                       foldfn (cdr foldable)))
2567               foldable))
2568      (if foldfn
2569        (funcall foldfn original-call environment)
2570        (progn
2571          (let ((args nil))
2572            (dolist (arg (cdr original-call) (setq args (nreverse args)))
2573              (if (quoted-form-p arg)
2574                (setq arg (%cadr arg))
2575                (unless (self-evaluating-p arg) (return-from nx-constant-fold (values original-call nil))))
2576              (push arg args))
2577            (if (nx1-check-call-args (fboundp fn) args nil)
2578              (return-from nx-constant-fold (values original-call nil))
2579              (setq form (multiple-value-list 
2580                             (handler-case (apply fn args)
2581                               (error (condition)
2582                                      (warn "Error: \"~A\" ~&signalled during compile-time evaluation of ~S ."
2583                                            condition original-call)
2584                                      (return-from nx-constant-fold
2585                                        (values `(locally (declare (notinline ,fn))
2586                                                  ,original-call)
2587                                                t))))))))
2588          (if form
2589            (if (null (%cdr form))
2590              (setq form (%car form))
2591              (setq mv (setq form (cons 'values (mapcar #'quotify form))))))
2592          (values (if mv form (quotify form)) T)))
2593      (values original-call nil))))
2594
2595(defun nx-transform-symbol (sym &optional (env *nx-lexical-environment*))
2596; Gak.  Can't call NX-LEX-INFO without establishing *nx-lexical-environment*.
2597; NX-LEX-INFO should take env arg!.
2598  (let* ((*nx-lexical-environment* env))
2599    (multiple-value-bind (expansion win) (macroexpand-1 sym env)
2600      (if win
2601        (let ((type (nx-declared-type sym))
2602              (var (nth-value 2 (nx-lex-info sym))))
2603          (unless (eq t type) (setq expansion `(the ,type ,expansion)))
2604          (if var (nx-set-var-bits var (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits var)))))
2605        (progn
2606          (multiple-value-setq (expansion win)
2607            (nx-transform-defined-constant sym env))
2608          (if win (setq win (neq sym expansion)))))
2609      (values expansion win))))
2610
2611; if sym has a substitutable constant value in env (or globally), return
2612; (values <value> t), else (values nil nil)
2613(defun nx-transform-defined-constant (sym env)
2614  (let* ((defenv (definition-environment env))
2615         (val (if defenv (assq sym (defenv.constants defenv))))
2616         (constant-value-p val))
2617    (if val
2618      (setq val (%cdr val))
2619      (if (constant-symbol-p sym)
2620        (setq constant-value-p t val (%sym-global-value sym))))
2621    (if (and (neq val (%unbound-marker-8))
2622             constant-value-p 
2623             (nx-substititute-constant-value sym val env))
2624      (values (if (self-evaluating-p val) val (list 'quote val)) t)
2625      (values nil nil))))
2626
2627
2628(defun nx-var-bits (var)
2629  (do* ((var var bits)
2630        (bits (var-bits var) (var-bits var)))
2631       ((fixnump bits) bits)))
2632
2633(defun nx-set-var-bits (var newbits)
2634  (do* ((var var bits)
2635        (bits (var-bits var) (var-bits var)))
2636       ((fixnump bits) (setf (var-bits var) newbits))))
2637
2638(defun nx-make-lexical-reference (var)
2639  (let* ((ref (make-acode (%nx1-operator lexical-reference) var)))
2640    (push ref (var-ref-forms var))
2641    ref))
2642
2643(defun nx-adjust-ref-count (var)
2644  (let* ((bits (nx-var-bits var))
2645         (temp-p (%ilogbitp $vbittemporary bits))
2646         (by (if temp-p 1 (expt  4 *nx-loop-nesting-level*)))
2647         (new (%imin (%i+ (%ilogand2 $vrefmask bits) by) 255)))
2648    (setf (var-refs var) (+ (var-refs var) by))
2649    (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vrefmask) bits) new))
2650    new))
2651
2652;;; Treat (VALUES x . y) as X if it appears in a THE form
2653(defun nx-form-type (form &optional (env *nx-lexical-environment*))
2654  (if (nx-form-constant-p form env)
2655    ;(type-of (nx-form-constant-value form env))
2656    `(member ,(nx-form-constant-value form env))
2657    (if (and (consp form)          ; Kinda bogus now, but require-type
2658             (eq (%car form) 'require-type) ; should be special some day
2659             (nx-form-constant-p (caddr form) env))
2660      (nx-form-constant-value (%caddr form) env)
2661      (if (nx-trust-declarations env)
2662        (if (symbolp form)
2663          (nx-target-type (nx-declared-type form env))
2664          (if (consp form)
2665            (if (eq (%car form) 'the)
2666              (destructuring-bind (typespec val) (%cdr form)
2667                (declare (ignore val))
2668                (nx-target-type (type-specifier (single-value-type (values-specifier-type typespec)))))
2669              (if (eq (%car form) 'setq)
2670                (let* ((args (%cdr form))
2671                       (n (length args)))
2672                  (if (and (evenp n)
2673                           (> n 0)
2674                           (setq args (nthcdr (- n 2) args))
2675                           (non-nil-symbol-p (car args)))
2676                    (nx1-type-intersect (%car args)
2677                                        (nx-declared-type (%car args) env)
2678                                        (nx-form-type (%cadr args) env)
2679                                        env)
2680                    t))
2681                (let* ((op (gethash (%car form) *nx1-operators*)))
2682                  (or (and op (cdr (assq op *nx-operator-result-types*)))
2683                      (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
2684                      #+no (and (memq (car form) *numeric-ops*)
2685                           (grovel-numeric-form form env))
2686                      #+no (and (memq (car form) *logical-ops*)
2687                           (grovel-logical-form form env))
2688                      (nx-declared-result-type (%car form) env (%cdr form))
2689                      t))))
2690            t))
2691        t))))
2692
2693
2694(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
2695
2696(defparameter *logical-ops* '(logxor-2 logior-2 logand-2  lognot logxor))
2697
2698(defun numeric-type-p (type &optional not-complex)
2699  (or (memq type '(fixnum integer double-float single-float float))
2700      (let ((ctype (specifier-type type)))
2701        (and (numeric-ctype-p ctype)
2702             (or (not not-complex)
2703                 (neq (numeric-ctype-complexp ctype) :complex))))))
2704
2705(defun grovel-numeric-form (form env)
2706  (let* ((op (car form))
2707         (args (cdr form)))
2708    (if (every #'(lambda (x) (nx-form-typep x 'float env)) args)
2709      (if (some #'(lambda (x) (nx-form-typep x 'double-float env)) args)
2710        'double-float
2711        'single-float)
2712      (if (every #'(lambda (x) (nx-form-typep x 'integer env)) args)
2713        (if (or (eq op '/) (eq op '/-2))
2714          t
2715          'integer)))))
2716
2717;; now e.g. logxor of 3 known fixnums is inline as is (logior a (logxor b c))
2718;; and (the fixnum (+ a (logxor b c)))
2719
2720(defun grovel-logical-form (form env)
2721  (when (nx-trust-declarations env)
2722    (let (;(op (car form))
2723          type)
2724      (dolist (arg (cdr form))
2725        (let ((it (nx-form-type arg env)))         
2726          (if (not (subtypep it 'fixnum))
2727            (return (setq type nil))
2728            (setq type 'fixnum))))
2729      type)))
2730
2731(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*))
2732  (setq type (nx-target-type (type-expand type)))
2733  (if (nx-form-constant-p arg env)
2734    (typep (nx-form-constant-value arg env) type env)
2735    (subtypep (nx-form-type arg env) type env)))
2736
2737(defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type)
2738  (setq form1 (nx-transform form1 env)
2739        form2 (nx-transform form2 env))
2740  (and
2741   (nx-form-typep form1 *nx-target-fixnum-type* env)
2742   (nx-form-typep form2 *nx-target-fixnum-type* env)
2743   (or ignore-result-type
2744        (and (nx-trust-declarations env)
2745             (subtypep *nx-form-type* *nx-target-fixnum-type*)))))
2746
2747
2748(defun nx-binary-natural-op-p (form1 form2 env &optional (ignore-result-type t))
2749  (and
2750   (nx-form-typep form1 *nx-target-natural-type* env)
2751   (nx-form-typep form2 *nx-target-natural-type* env)
2752   (or ignore-result-type
2753       (and (nx-trust-declarations env)
2754            (subtypep *nx-form-type* *nx-target-natural-type*)))))
2755
2756(defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop)
2757  (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t))
2758         (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
2759    (if (or use-fixop use-naturalop intop)
2760      (make-acode (%nx1-operator typed-form)
2761                  (if use-fixop *nx-target-fixnum-type*
2762                    (if use-naturalop *nx-target-natural-type* 'integer))
2763                  (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
2764                              (nx1-form arg-1)
2765                              (nx1-form arg-2)))
2766      (nx1-treat-as-call whole))))
2767
2768(defun nx-global-p (sym &optional (env *nx-lexical-environment*))
2769  (or 
2770   (logbitp $sym_vbit_global (the fixnum (%symbol-bits sym)))
2771   (let* ((defenv (definition-environment env)))
2772     (if defenv 
2773       (eq :global (%cdr (assq sym (defenv.specials defenv))))))))
2774 
2775(defun nx-need-var (sym &optional (check-bindable t))
2776  (if (and (nx-need-sym sym)
2777           (not (constantp sym))
2778           (let* ((defenv (definition-environment *nx-lexical-environment*)))
2779             (or (null defenv)
2780                 (not (assq sym (defenv.constants defenv)))))) ; check compile-time-constants, too
2781    (if (and check-bindable (nx-global-p sym))
2782      (nx-error "~S is declared static and can not be bound" sym)
2783      sym)
2784    (nx-error "Can't bind or assign to constant ~S." sym)))
2785
2786(defun nx-need-sym (sym)
2787  (if (symbolp sym)
2788    sym
2789    (nx-error "~S is not a symbol." sym)))
2790
2791(defun nx-need-function-name (name)
2792  (multiple-value-bind (valid nm) (valid-function-name-p name)
2793    (if valid nm (nx-error "Invalid function name ~S" name))))
2794
2795(defun nx-pair-name (form)
2796  (nx-need-sym (if (consp form) (%car form) form)))
2797
2798(defun nx-pair-initform (form)
2799  (if (atom form)
2800    nil
2801    (if (and (listp (%cdr form)) (null (%cddr form)))
2802      (%cadr form)
2803      (nx-error "Bad initialization form: ~S." form))))
2804
2805; some callers might assume that this guy errors out if it can't conjure up
2806; a fixnum.  I certainly did ...
2807(defun nx-get-fixnum (form &aux (trans (nx-transform form *nx-lexical-environment*)))
2808 (if (fixnump trans)
2809  trans
2810  form))
2811 
2812(defun nx1-func-name (gizmo)
2813  (and (consp gizmo)
2814       (eq (%car gizmo) 'function)
2815       (consp (%cdr gizmo))
2816       (null (%cddr gizmo))
2817       (if (lambda-expression-p (%cadr gizmo))
2818         (%cadr gizmo)
2819         (nth-value 1 (valid-function-name-p (%cadr gizmo))))))
2820
2821; distinguish between program errors & incidental ones.
2822(defun nx-error (format-string &rest args)
2823  (error (make-condition 'compile-time-program-error 
2824                :context (nx-error-context)
2825                :format-control format-string
2826                :format-arguments args)))
2827
2828(defun nx-compile-time-error (format-string &rest args)
2829  (error (make-condition 'compile-time-program-error 
2830                :context (nx-error-context)
2831                :format-control format-string
2832                :format-arguments args)))
2833
2834; Should return information about file being compiled, nested functions, etc. ...
2835(defun nx-error-context ()
2836  (or *nx-cur-func-name* "an anonymous function"))
2837
2838(defparameter *warn-if-function-result-ignored*
2839  '(sort stable-sort delete delete-if delete-if-not remf nreverse
2840    nunion nset-intersection)
2841  "Names of functions whose result(s) should ordinarily be used, because of their side-effects or lack of them.")
Note: See TracBrowser for help on using the repository browser.