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

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

compiler/optimizers.lisp: * (multiplication) compiler-macro: always
transform into a sequence of pairwise multiplications.

other files: compiler frontend changes, largely intended to address
ticket:186. These changes are a bit hard to bootstrap; new images
soon.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 113.6 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  (declare (notinline innermost-lfun-bits-keyvect))
2100  (let* ((inner-def (closure-function (find-unencapsulated-definition def)))
2101         (bits (lfun-bits inner-def))
2102         (keys (lfun-keyvect inner-def)))
2103    (declare (fixnum bits))
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
2113(defun nx1-check-call-args (def arglist spread-p)
2114  (let* ((deftype (if (functionp def) 
2115                    :global-mismatch
2116                    (if (istruct-typep def 'afunc)
2117                      :lexical-mismatch
2118                      :environment-mismatch)))
2119         (reason nil))
2120    (multiple-value-bind (bits keyvect)
2121                         (case deftype
2122                           (:global-mismatch (innermost-lfun-bits-keyvect def))
2123                           (:environment-mismatch
2124                              (values (def-info.lfbits (cdr def)) (def-info.keyvect (cdr def))))
2125                           (t (let* ((lambda-form (afunc-lambdaform def)))
2126                                (if (lambda-expression-p lambda-form)
2127                                  (encode-lambda-list (cadr lambda-form))))))
2128      (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
2129      (when reason
2130        (values deftype reason)))))
2131
2132(defun nx1-check-call-bits (bits keyvect arglist spread-p)
2133  (when bits
2134    (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
2135    (let* ((env *nx-lexical-environment*)
2136           (nargs (length arglist))
2137           (minargs (if spread-p (1- nargs) nargs))
2138           (required (ldb $lfbits-numreq bits))
2139           (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
2140                  nil
2141                  (+ required (ldb $lfbits-numopt bits)))))
2142      ;; If the (apparent) number of args in the call doesn't
2143      ;; match the definition, complain.  If "spread-p" is true,
2144      ;; we can only be sure of the case when more than the
2145      ;; required number of args have been supplied.
2146      (or (and (not spread-p)
2147               (< minargs required)
2148               `(:toofew ,minargs ,required))
2149          (and max
2150               (> minargs max)
2151               (list :toomany nargs max))
2152          (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
2153
2154(defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
2155  (declare (fixnum bits))
2156  (when (logbitp $lfbits-aok-bit bits)
2157    (setq keyvect nil))                 ; only check for even length tail
2158  (when (and (logbitp $lfbits-keys-bit bits) 
2159             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
2160    (do* ((bad-keys nil)
2161          (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
2162          (key-args key-values  (cddr key-args)))
2163         ((null key-args)
2164          (when (and keyvect bad-keys)
2165            (list :unknown-keyword
2166                  (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
2167                  (coerce keyvect 'list))))
2168      (unless (cdr key-args)
2169        (return (list :odd-keywords key-values)))
2170      (when keyvect
2171        (let* ((keyword (%car key-args)))
2172          (unless (nx-form-constant-p keyword env)
2173            (return nil))
2174          (setq keyword (nx-form-constant-value keyword env))
2175          (if (eq keyword :allow-other-keys)
2176            (setq keyvect nil)
2177            (unless (position keyword keyvect)
2178              (push keyword bad-keys))))))))
2179
2180;;; we can save some space by going through subprims to call "builtin"
2181;;; functions for us.
2182(defun nx1-builtin-function-offset (name)
2183   (arch::builtin-function-name-offset name))
2184
2185(defun nx1-call-form (global-name afunc arglist spread-p  &optional (env *nx-lexical-environment*))
2186  (if afunc
2187    (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p)
2188    (let* ((builtin (unless (or spread-p
2189                                (eql 3 (safety-optimize-quantity env)))
2190                      (nx1-builtin-function-offset global-name))))
2191      (if (and builtin
2192               (let* ((bits (lfun-bits (fboundp global-name))))
2193                 (and bits (eql (logand $lfbits-args-mask bits)
2194                                (dpb (length arglist)
2195                                     $lfbits-numreq
2196                                     0)))))
2197        (make-acode (%nx1-operator builtin-call) 
2198                    (make-acode (%nx1-operator fixnum) builtin)
2199                    (nx1-arglist arglist))
2200        (make-acode (%nx1-operator call)
2201                     (if (symbolp global-name)
2202                       (nx1-immediate (nx1-note-fcell-ref global-name))
2203                       global-name)
2204                     (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*)))
2205                     spread-p)))))
2206 
2207;;; If "sym" is an expression (not a symbol which names a function),
2208;;; the caller has already alphatized it.
2209(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
2210  (nx1-verify-length args 0 nil)
2211  (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
2212    (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
2213      (when valid
2214        (setq global-only t sym name))))
2215  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
2216    (if (nx-self-call-p sym global-only)
2217      ;; Should check for downward functions here as well.
2218      (multiple-value-bind (deftype reason)
2219                           (nx1-check-call-args *nx-current-function* args spread-p)
2220        (when deftype
2221          (nx1-whine deftype sym reason args spread-p))
2222        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
2223      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
2224        (or (and (not inhibit-inline)
2225                 (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*))
2226            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
2227              (when (eq 'macro (car info))
2228                (nx-error "Can't call macro function ~s" sym))
2229              (nx-record-xref-info :direct-calls sym)
2230              (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc)))
2231                (let ((sym (var-name (afunc-lfun afunc))))
2232                  (nx1-form 
2233                   (if spread-p
2234                     `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
2235                     `(funcall ,sym ,@args))))
2236                (let* ((val (nx1-call-form sym afunc args spread-p)))
2237                    (when afunc
2238                      (let ((callers (afunc-callers afunc))
2239                            (self *nx-current-function*))
2240                        (unless (or (eq self afunc) (memq self callers))
2241                          (setf (afunc-callers afunc) (cons self callers)))))
2242                    (if (and (null afunc) (memq sym *nx-never-tail-call*))
2243                      (make-acode (%nx1-operator values) (list val))
2244                      val)))))))))
2245
2246(defun nx1-expand-inline-call (lambda-form env token args spread-p old-env)
2247  (if (and (or (null spread-p) (eq (length args) 1)))
2248    (if (and token (not (memq token *nx-inline-expansions*)))
2249      (with-program-error-handler (lambda (c) (declare (ignore c)) nil)
2250        (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
2251               (lambda-list (cadr lambda-form))
2252               (body (cddr lambda-form))
2253               (new-env (new-lexical-environment env)))
2254          (setf (lexenv.mdecls new-env)
2255                `((speed . ,(speed-optimize-quantity old-env))
2256                  (space . ,(space-optimize-quantity old-env))
2257                  (safety . ,(space-optimize-quantity old-env))
2258                  (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
2259                  (debug . ,(debug-optimize-quantity old-env))))
2260          (if spread-p
2261            (nx1-destructure lambda-list (car args) nil nil body new-env)
2262            (nx1-lambda-bind lambda-list args body new-env)))))))
2263             
2264; note that regforms are reversed: arg_z is always in the car
2265(defun nx1-arglist (args &optional (nregargs (backend-num-arg-regs *target-backend*)))
2266  (declare (fixnum nregargs))
2267  (let* ((stkforms nil)
2268         (regforms nil)
2269         (nstkargs (%i- (length args) nregargs)))
2270    (declare (fixnum nstkargs))
2271      (list
2272       (dotimes (i nstkargs (nreverse stkforms))
2273         (declare (fixnum i))
2274         (push (nx1-form (%car args)) stkforms)
2275         (setq args (%cdr args)))
2276       (dolist (arg args regforms)
2277         (push (nx1-form arg) regforms)))))
2278
2279(defun nx1-formlist (args)
2280  (let* ((a nil))
2281    (dolist (arg args)
2282      (push (nx1-form arg) a))
2283    (nreverse a)))
2284
2285(defun nx1-verify-length (forms min max &aux (len (list-length forms)))
2286 (if (or (null len)
2287         (%i> min len)
2288         (and max (%i> len max)))
2289     (nx-error "Wrong number of args in form ~S." (cons *nx-sfname* forms))
2290     len))
2291
2292(defun nx-unquote (form)
2293  (if (nx-quoted-form-p form)
2294    (%cadr form)
2295    form))
2296
2297(defun nx-quoted-form-p (form &aux (f form))
2298 (and (consp form)
2299      (eq (pop form) 'quote)
2300      (or
2301       (and (consp form)
2302            (not (%cdr form)))
2303       (nx-error "Illegally quoted form ~S." f))))
2304
2305(defun nx-form-constant-p (form env)
2306  (declare (ignore env))
2307  (or (quoted-form-p form)
2308      (self-evaluating-p form)))
2309
2310(defun nx-form-constant-value (form env)
2311  (declare (ignore env))
2312  (declare (type (satisfies nx-form-constant-p) form))
2313  (if (consp form) (%cadr form) form))
2314
2315; Returns two values: expansion & win
2316; win is true if expansion is not EQ to form.
2317; This is a bootstrapping version.
2318; The real one is in "ccl:compiler;optimizers.lisp".
2319(unless (fboundp 'maybe-optimize-slot-accessor-form)
2320
2321(defun maybe-optimize-slot-accessor-form (form environment)
2322  (declare (ignore environment))
2323  (values form nil))
2324
2325)
2326
2327(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
2328  (when source-notes
2329    (when (or (consp form) (vectorp form) (pathnamep form))
2330      (let ((note (gethash form source-notes)))
2331        (unless (listp note) note)))))
2332
2333
2334(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
2335  (macrolet ((form-changed (form)
2336               `(progn
2337                  (unless source (setq source (gethash ,form source-note-map)))
2338                  (setq changed t))))
2339    (prog (sym transforms lexdefs changed enabled macro-function compiler-macro (source t))
2340       (when source-note-map
2341         (setq source (gethash form source-note-map)))
2342       (go START)
2343     LOOP
2344       (form-changed form)
2345       (when (and (consp form) 
2346                  (or (eq (%car form) 'the)
2347                      (and sym (eq (%car form) sym))))
2348         (go DONE))
2349     START
2350       (when (non-nil-symbol-p form)
2351         (multiple-value-bind (newform win) (nx-transform-symbol form environment)
2352           (unless win (go DONE))
2353           (setq form newform)
2354           (go LOOP)))
2355       (when (atom form) (go DONE))
2356       (unless (symbolp (setq sym (%car form)))
2357         (go DONE))
2358       #+no
2359       (when (eq sym 'the)
2360         (destructuring-bind (typespec thing) (cdr form)
2361           (if (constantp thing)
2362             (progn
2363               (setq form thing)
2364               (go LOOP))
2365             (multiple-value-bind (newform win) (nx-transform thing environment source-note-map)
2366               (when win
2367                 (form-changed newform)
2368                 (if (and (self-evaluating-p newform)
2369                          (typep newform typespec))
2370                   (setq form newform)
2371                   (setq form `(the ,typespec ,newform)))
2372                 (go DONE))))))
2373       (when (nx-quoted-form-p form)
2374         (when (self-evaluating-p (%cadr form))
2375           (setq form (%cadr form)))
2376         (go DONE))
2377       (when (setq lexdefs (nx-lexical-finfo sym environment))
2378         (if (eq 'function (%car lexdefs))
2379           (go DONE)))
2380       (setq transforms (setq compiler-macro (compiler-macro-function sym environment))
2381             macro-function (macro-function sym environment)
2382             enabled (nx-allow-transforms environment))
2383       (unless macro-function
2384         (let* ((win nil))
2385           (when (and enabled (functionp (fboundp sym)))
2386             (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map))
2387             (when win
2388               (form-changed form)))))
2389       (when (and enabled
2390                  (not (nx-declared-notinline-p sym environment)))
2391         (multiple-value-bind (value folded) (nx-constant-fold form environment)
2392           (when folded
2393             (setq form value)
2394             (form-changed form)
2395             (unless (and (consp form) (eq (car form) sym)) (go START))))
2396         (when compiler-macro
2397           (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
2398             (when win
2399               (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym)))
2400                 (setq sym nil))
2401               (setq form newform)
2402               (go LOOP))))
2403         (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment)
2404           (when win
2405             (setq sym nil)
2406             (setq form newform)
2407             (go START)))
2408         (unless macro-function
2409           (when (setq transforms (or (environment-structref-info sym environment)
2410                                      (and (boundp '%structure-refs%)
2411                                           (gethash sym %structure-refs%))))
2412             (setq form (defstruct-ref-transform transforms (%cdr form) environment))
2413             (form-changed form)
2414             (go START))
2415           (when (setq transforms (assq sym *nx-synonyms*))
2416             (setq form (cons (%cdr transforms) (setq sym (%cdr form))))
2417             (go LOOP))))
2418       (when (and macro-function
2419                  (or lexdefs
2420                      (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment))))))
2421         (nx-record-xref-info :macro-calls (function-name macro-function))
2422         (setq form (macroexpand-1 form environment))
2423         (form-changed form)
2424         (go START))
2425     DONE
2426       (if (eq source t)
2427         (setq source nil)
2428         (let ((this (nx-source-note form)))
2429           (if this
2430             (setq source this)
2431             (when source
2432               (unless (and (consp form)
2433                            (eq (%car form) 'the)
2434                            (eq source (gethash (caddr form) source-note-map)))
2435                 (when (or (consp form) (vectorp form) (pathnamep form))
2436                   (unless (or (eq form (%unbound-marker))
2437                               (eq form (%slot-unbound-marker)))
2438                     (setf (gethash form source-note-map) source))))))))
2439       ;; Return source for symbols, even though don't record it in hash table.
2440       (return (values form changed source)))))
2441
2442
2443; Transform all of the arguments to the function call form.
2444; If any of them won, return a new call form (with the same operator as the original), else return the original
2445; call form unchanged.
2446(defun nx-transform-arglist (callform env source-note-map)
2447  (let* ((any-wins nil)
2448         (transformed-call (cons (car callform) nil))
2449         (ptr transformed-call)
2450         (win nil))
2451    (declare (type cons ptr))
2452    (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
2453      (multiple-value-setq (form win) (nx-transform form env source-note-map))
2454      (rplacd ptr (setq ptr (cons form nil)))
2455      (if win (setq any-wins t)))))
2456
2457;This is needed by (at least) SETF.
2458(defun nxenv-local-function-p (name macro-env)
2459  (multiple-value-bind (type local-p) (function-information name macro-env)
2460    (and local-p (eq :function type))))
2461
2462           
2463;;; This guy has to return multiple values.  The arguments have
2464;;; already been transformed; if they're all constant (or quoted), try
2465;;; to evaluate the expression at compile-time.
2466(defun nx-constant-fold (original-call &optional (environment *nx-lexical-environment*) &aux 
2467                                       (fn (car original-call)) form mv foldable foldfn)
2468  (flet ((quotify (x) (if (self-evaluating-p x) x (list 'quote x))))
2469    (if (and (nx-allow-transforms environment)
2470             (let* ((bits (if (symbolp fn) (%symbol-bits fn) 0)))
2471               (declare (fixnum bits))
2472               (if (setq foldable (logbitp $sym_fbit_constant_fold bits))
2473                 (if (logbitp $sym_fbit_fold_subforms bits)
2474                   (setq foldfn 'fold-constant-subforms))
2475                 (setq foldable (assq fn *nx-can-constant-fold*)
2476                       foldfn (cdr foldable)))
2477               foldable))
2478      (if foldfn
2479        (funcall foldfn original-call environment)
2480        (progn
2481          (let ((args nil))
2482            (dolist (arg (cdr original-call) (setq args (nreverse args)))
2483              (if (quoted-form-p arg)
2484                (setq arg (%cadr arg))
2485                (unless (self-evaluating-p arg) (return-from nx-constant-fold (values original-call nil))))
2486              (push arg args))
2487            (if (nx1-check-call-args (fboundp fn) args nil)
2488              (return-from nx-constant-fold (values original-call nil))
2489              (setq form (multiple-value-list 
2490                             (handler-case (apply fn args)
2491                               (error (condition)
2492                                      (warn "Error: \"~A\" ~&signalled during compile-time evaluation of ~S ."
2493                                            condition original-call)
2494                                      (return-from nx-constant-fold
2495                                        (values `(locally (declare (notinline ,fn))
2496                                                  ,original-call)
2497                                                t))))))))
2498          (if form
2499            (if (null (%cdr form))
2500              (setq form (%car form))
2501              (setq mv (setq form (cons 'values (mapcar #'quotify form))))))
2502          (values (if mv form (quotify form)) T)))
2503      (values original-call nil))))
2504
2505(defun nx-transform-symbol (sym &optional (env *nx-lexical-environment*))
2506; Gak.  Can't call NX-LEX-INFO without establishing *nx-lexical-environment*.
2507; NX-LEX-INFO should take env arg!.
2508  (let* ((*nx-lexical-environment* env))
2509    (multiple-value-bind (expansion win) (macroexpand-1 sym env)
2510      (if win
2511        (let ((type (nx-declared-type sym))
2512              (var (nth-value 2 (nx-lex-info sym))))
2513          (unless (eq t type) (setq expansion `(the ,type ,expansion)))
2514          (if var (nx-set-var-bits var (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits var)))))
2515        (progn
2516          (multiple-value-setq (expansion win)
2517            (nx-transform-defined-constant sym env))
2518          (if win (setq win (neq sym expansion)))))
2519      (values expansion win))))
2520
2521; if sym has a substitutable constant value in env (or globally), return
2522; (values <value> t), else (values nil nil)
2523(defun nx-transform-defined-constant (sym env)
2524  (let* ((defenv (definition-environment env))
2525         (val (if defenv (assq sym (defenv.constants defenv))))
2526         (constant-value-p val))
2527    (if val
2528      (setq val (%cdr val))
2529      (if (constant-symbol-p sym)
2530        (setq constant-value-p t val (%sym-global-value sym))))
2531    (if (and (neq val (%unbound-marker-8))
2532             constant-value-p 
2533             (nx-substititute-constant-value sym val env))
2534      (values (if (self-evaluating-p val) val (list 'quote val)) t)
2535      (values nil nil))))
2536
2537
2538(defun nx-var-bits (var)
2539  (do* ((var var bits)
2540        (bits (var-bits var) (var-bits var)))
2541       ((fixnump bits) bits)))
2542
2543(defun nx-set-var-bits (var newbits)
2544  (do* ((var var bits)
2545        (bits (var-bits var) (var-bits var)))
2546       ((fixnump bits) (setf (var-bits var) newbits))))
2547
2548(defun nx-make-lexical-reference (var)
2549  (let* ((ref (make-acode (%nx1-operator lexical-reference) var)))
2550    (push ref (var-ref-forms var))
2551    ref))
2552
2553(defun nx-adjust-ref-count (var)
2554  (let* ((bits (nx-var-bits var))
2555         (temp-p (%ilogbitp $vbittemporary bits))
2556         (by (if temp-p 1 (expt  4 *nx-loop-nesting-level*)))
2557         (new (%imin (%i+ (%ilogand2 $vrefmask bits) by) 255)))
2558    (setf (var-refs var) (+ (var-refs var) by))
2559    (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vrefmask) bits) new))
2560    new))
2561
2562;;; Treat (VALUES x . y) as X if it appears in a THE form
2563(defun nx-form-type (form &optional (env *nx-lexical-environment*))
2564  (if (nx-form-constant-p form env)
2565    ;(type-of (nx-form-constant-value form env))
2566    `(member ,(nx-form-constant-value form env))
2567    (if (and (consp form)          ; Kinda bogus now, but require-type
2568             (eq (%car form) 'require-type) ; should be special some day
2569             (nx-form-constant-p (caddr form) env))
2570      (nx-form-constant-value (%caddr form) env)
2571      (if (nx-trust-declarations env)
2572        (if (symbolp form)
2573          (nx-target-type (nx-declared-type form env))
2574          (if (consp form)
2575            (if (eq (%car form) 'the)
2576              (destructuring-bind (typespec val) (%cdr form)
2577                (declare (ignore val))
2578                (nx-target-type (type-specifier (single-value-type (values-specifier-type typespec)))))
2579              (if (eq (%car form) 'setq)
2580                (let* ((args (%cdr form))
2581                       (n (length args)))
2582                  (if (and (evenp n)
2583                           (> n 0)
2584                           (setq args (nthcdr (- n 2) args))
2585                           (non-nil-symbol-p (car args)))
2586                    (nx1-type-intersect (%car args)
2587                                        (nx-declared-type (%car args) env)
2588                                        (nx-form-type (%cadr args) env)
2589                                        env)
2590                    t))
2591                (let* ((op (gethash (%car form) *nx1-operators*)))
2592                  (or (and op (cdr (assq op *nx-operator-result-types*)))
2593                      (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
2594                      #+no (and (memq (car form) *numeric-ops*)
2595                           (grovel-numeric-form form env))
2596                      #+no (and (memq (car form) *logical-ops*)
2597                           (grovel-logical-form form env))
2598                      (nx-declared-result-type (%car form) env)
2599                      ;; Sort of the right idea, but this should be done
2600                      ;; in a more general way.
2601                      (when (or (eq (car form) 'aref)
2602                                (eq (car form) 'uvref))
2603                        (let* ((atype (nx-form-type (cadr form) env))
2604                               (a-ctype (specifier-type atype)))
2605                          (when (array-ctype-p a-ctype)
2606                            (type-specifier (array-ctype-specialized-element-type
2607                                             a-ctype)))))
2608                      t))))
2609            t))
2610        t))))
2611
2612
2613(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
2614
2615(defparameter *logical-ops* '(logxor-2 logior-2 logand-2  lognot logxor))
2616
2617(defun numeric-type-p (type &optional not-complex)
2618  (or (memq type '(fixnum integer double-float single-float float))
2619      (let ((ctype (specifier-type type)))
2620        (and (numeric-ctype-p ctype)
2621             (or (not not-complex)
2622                 (neq (numeric-ctype-complexp ctype) :complex))))))
2623
2624(defun grovel-numeric-form (form env)
2625  (let* ((op (car form))
2626         (args (cdr form)))
2627    (if (every #'(lambda (x) (nx-form-typep x 'float env)) args)
2628      (if (some #'(lambda (x) (nx-form-typep x 'double-float env)) args)
2629        'double-float
2630        'single-float)
2631      (if (every #'(lambda (x) (nx-form-typep x 'integer env)) args)
2632        (if (or (eq op '/) (eq op '/-2))
2633          t
2634          'integer)))))
2635
2636;; now e.g. logxor of 3 known fixnums is inline as is (logior a (logxor b c))
2637;; and (the fixnum (+ a (logxor b c)))
2638
2639(defun grovel-logical-form (form env)
2640  (when (nx-trust-declarations env)
2641    (let (;(op (car form))
2642          type)
2643      (dolist (arg (cdr form))
2644        (let ((it (nx-form-type arg env)))         
2645          (if (not (subtypep it 'fixnum))
2646            (return (setq type nil))
2647            (setq type 'fixnum))))
2648      type)))
2649
2650(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*))
2651  (setq type (nx-target-type (type-expand type)))
2652  (if (nx-form-constant-p arg env)
2653    (typep (nx-form-constant-value arg env) type env)
2654    (subtypep (nx-form-type arg env) type env)))
2655
2656
2657(defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type)
2658  (setq form1 (nx-transform form1 env)
2659        form2 (nx-transform form2 env))
2660  (and
2661   (target-word-size-case
2662    (32 (nx-form-typep form1 '(signed-byte 30) env))
2663    (64 (nx-form-typep form1 '(signed-byte 61) env)))
2664   (target-word-size-case
2665    (32 (nx-form-typep form2 '(signed-byte 30) env))
2666    (64 (nx-form-typep form2 '(signed-byte 61) env)))
2667   (or ignore-result-type
2668        (and (nx-trust-declarations env)
2669                (target-word-size-case
2670                 (32 (subtypep *nx-form-type* '(signed-byte 30)))
2671                 (64 (subtypep *nx-form-type* '(signed-byte 61))))))))
2672
2673
2674(defun nx-binary-natural-op-p (form1 form2 env &optional (ignore-result-type t))
2675  (and
2676   (target-word-size-case
2677    (32
2678     (and (nx-form-typep form1 '(unsigned-byte 32)  env)
2679          (nx-form-typep form2 '(unsigned-byte 32)  env)))
2680    (64
2681     (and (nx-form-typep form1 '(unsigned-byte 64)  env)
2682          (nx-form-typep form2 '(unsigned-byte 64)  env))))
2683   (or ignore-result-type
2684       (and (nx-trust-declarations env)
2685            (target-word-size-case
2686             (32 (subtypep *nx-form-type* '(unsigned-byte 32)))
2687             (64 (subtypep *nx-form-type* '(unsigned-byte 64))))))))
2688
2689   
2690
2691
2692(defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop)
2693  (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t))
2694         (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
2695    (if (or use-fixop use-naturalop intop)
2696      (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
2697                  (nx1-form arg-1)
2698                  (nx1-form arg-2))
2699      (nx1-treat-as-call whole))))
2700
2701(defun nx-global-p (sym &optional (env *nx-lexical-environment*))
2702  (or 
2703   (logbitp $sym_vbit_global (the fixnum (%symbol-bits sym)))
2704   (let* ((defenv (definition-environment env)))
2705     (if defenv 
2706       (eq :global (%cdr (assq sym (defenv.specials defenv))))))))
2707 
2708(defun nx-need-var (sym &optional (check-bindable t))
2709  (if (and (nx-need-sym sym)
2710           (not (constantp sym))
2711           (let* ((defenv (definition-environment *nx-lexical-environment*)))
2712             (or (null defenv)
2713                 (not (assq sym (defenv.constants defenv)))))) ; check compile-time-constants, too
2714    (if (and check-bindable (nx-global-p sym))
2715      (nx-error "~S is declared static and can not be bound" sym)
2716      sym)
2717    (nx-error "Can't bind or assign to constant ~S." sym)))
2718
2719(defun nx-need-sym (sym)
2720  (if (symbolp sym)
2721    sym
2722    (nx-error "~S is not a symbol." sym)))
2723
2724(defun nx-need-function-name (name)
2725  (multiple-value-bind (valid nm) (valid-function-name-p name)
2726    (if valid nm (nx-error "Invalid function name ~S" name))))
2727
2728(defun nx-pair-name (form)
2729  (nx-need-sym (if (consp form) (%car form) form)))
2730
2731(defun nx-pair-initform (form)
2732  (if (atom form)
2733    nil
2734    (if (and (listp (%cdr form)) (null (%cddr form)))
2735      (%cadr form)
2736      (nx-error "Bad initialization form: ~S." form))))
2737
2738; some callers might assume that this guy errors out if it can't conjure up
2739; a fixnum.  I certainly did ...
2740(defun nx-get-fixnum (form &aux (trans (nx-transform form *nx-lexical-environment*)))
2741 (if (fixnump trans)
2742  trans
2743  form))
2744 
2745(defun nx1-func-name (gizmo)
2746  (and (consp gizmo)
2747       (eq (%car gizmo) 'function)
2748       (consp (%cdr gizmo))
2749       (null (%cddr gizmo))
2750       (if (lambda-expression-p (%cadr gizmo))
2751         (%cadr gizmo)
2752         (nth-value 1 (valid-function-name-p (%cadr gizmo))))))
2753
2754; distinguish between program errors & incidental ones.
2755(defun nx-error (format-string &rest args)
2756  (error (make-condition 'compile-time-program-error 
2757                :context (nx-error-context)
2758                :format-control format-string
2759                :format-arguments args)))
2760
2761(defun nx-compile-time-error (format-string &rest args)
2762  (error (make-condition 'compile-time-program-error 
2763                :context (nx-error-context)
2764                :format-control format-string
2765                :format-arguments args)))
2766
2767; Should return information about file being compiled, nested functions, etc. ...
2768(defun nx-error-context ()
2769  (or *nx-cur-func-name* "an anonymous function"))
2770
2771(defparameter *warn-if-function-result-ignored*
2772  '(sort stable-sort delete delete-if delete-if-not remf nreverse
2773    nunion nset-intersection)
2774  "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.