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

Last change on this file since 15526 was 15526, checked in by gb, 7 years ago

Change the way that (APPLY inlined-functon args) inlines: don't use the
ancient DEBIND mechanism (which depends on a hairy subprim in the kernel
and which generates fairly bad code), but "manually" do a LET* and a
DESTRUCTURING-BIND with some environment hacking in NX1-DESTRUCTURE.

The environment hacking (processing the inlined function in the lexical
environment in which it was defined) was the argument for using the
magical DEBIND mechanism. However, it's been a while (if ever) since
we inlined anything that was defined in a non-null lexical environment,
so we didn't really retain the environment of definition. Hack things
up to do so, at least in the case where the inlined function is defined
in the current (file-)compilation environment. This involved changing
some of the def-info.* acccessors, and bootstrapping it involved moving
some of those accessors from l1-readloop.lisp to nx.lisp, at least for
the time being.

Change the implementation of DESTRUCTURING-BIND: don't use a
DESTRUCTURE-STATE object, do generate code to explicitly check the
length of the list wrt the lambda-list (and try to signal clear errors
if the check fails), and don't be so sloppy about binding SUPPLIED-P
variables for &optional/&key before the corresponding variables.
(This sloppiness caused us to not warn about an unused supplied-p
variable in PPRINT-LOGICAL-BLOCK.)

Since the new DESTRUCTURING-BIND code expands into many POPs, try
to make PROG1 better about unnecessary pushes/pops to the stack
in the x86 backend. (Should do this on ARM too; it's not that
critical in the DESTRUCTURING-BIND case but may matter elsewhere.)

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