source: branches/qres/ccl/compiler/nx0.lisp @ 14058

Last change on this file since 14058 was 14058, checked in by gz, 9 years ago

support for code coverage of acode (r13891, r13929, r13942, r13964, r13965, r13966, r14044)

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