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

Last change on this file since 12940 was 12940, checked in by gz, 10 years ago

From working-0711 branch: more extensive compile-time checking involving methods/gfs: warn about incongruent lambda lists, duplicate gf defs, required keyword args (from defgeneric), and invalid keyword args in gf calls. Also fix to keep method source files in env function info so dup method warnings can cite the right file.

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