source: trunk/ccl/compiler/nx0.lisp @ 4173

Last change on this file since 4173 was 4173, checked in by gb, 15 years ago

NX-U31-CONSTANT-P.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 87.2 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 (allocate-typed-vector :istruct $afunc-size nil)))
31  (setf (%svref v 0) 'afunc)
32  (setf (afunc-fn-refcount v) 0)
33  (setf (afunc-fn-downward-refcount v) 0)
34  (setf (afunc-bits v) 0)
35  v)
36
37(defvar *nx-blocks* nil)
38(defvar *nx-tags* nil)
39(defvar *nx-parent-function* nil)
40(defvar *nx-current-function* nil)
41(defvar *nx-lexical-environment* nil)
42(defvar *nx-symbol-macros* nil)
43(defvar *nx-inner-functions* nil)
44(defvar *nx-cur-func-name* nil)
45(defvar *nx-form-type* t)
46;(defvar *nx-proclaimed-inline* nil)
47;(defvar *nx-proclaimed-inline* (make-hash-table :size 400 :test #'eq))
48(defvar *nx-proclaimed-ignore* nil)
49(defvar *nx-parsing-lambda-decls* nil) ; el grosso.
50(defparameter *nx-standard-declaration-handlers* nil)
51(defparameter *nx-hoist-declarations* t)
52(defparameter *nx-loop-nesting-level* 0)
53
54(defvar *nx1-vcells* nil)
55(defvar *nx1-fcells* nil)
56
57(defvar *nx1-operators* (make-hash-table :size 160 :test #'eq))
58
59                                         
60
61; The compiler can (generally) use temporary vectors for VARs.
62(defun nx-cons-var (name &optional (bits 0))
63  (%istruct 'var name bits nil nil nil nil))
64
65
66
67
68(defvar *nx-lambdalist* (make-symbol "lambdalist"))
69(defvar *nx-nil* (list (make-symbol "nil")))
70(defvar *nx-t* (list (make-symbol "t")))
71
72(defparameter *nx-current-compiler-policy* (%default-compiler-policy))
73
74(defvar *nx-next-method-var* nil)
75(defvar *nx-call-next-method-function* nil)
76
77(defvar *nx-sfname* nil)
78(defvar *nx-operators* ())
79(defvar *nx-warnings* nil)
80
81(defvar *nx1-compiler-special-forms* nil "Real special forms")
82
83(defparameter *nx-never-tail-call*
84  '(error cerror break warn type-error file-error
85    signal-program-error signal-simple-program-error
86    #-bccl %get-frame-pointer
87    #-bccl break-loop)
88  "List of functions which never return multiple values and
89   should never be tail-called.")
90
91(defvar *cross-compiling* nil "bootstrapping")
92
93
94
95(defparameter *nx-operator-result-types*
96  '((#.(%nx1-operator list) . list)
97    (#.(%nx1-operator memq) . list)
98    (#.(%nx1-operator %temp-list) . list)
99    (#.(%nx1-operator assq) . list)
100    (#.(%nx1-operator cons) . cons)
101    (#.(%nx1-operator rplaca) . cons)
102    (#.(%nx1-operator %rplaca) . cons)
103    (#.(%nx1-operator rplacd) . cons)
104    (#.(%nx1-operator %rplacd) . cons)
105    (#.(%nx1-operator %temp-cons) . cons)
106    (#.(%nx1-operator %i+) . fixnum)
107    (#.(%nx1-operator %i-) . fixnum)
108    (#.(%nx1-operator %i*) . fixnum)
109    (#.(%nx1-operator %ilsl) . fixnum)
110    (#.(%nx1-operator %ilsr) . fixnum)
111    (#.(%nx1-operator %iasr) . fixnum)
112    (#.(%nx1-operator %ilogior2) . fixnum)
113    (#.(%nx1-operator %ilogand2) . fixnum)
114    (#.(%nx1-operator %ilogxor2) . fixnum)
115    (#.(%nx1-operator %code-char) . character)
116    (#.(%nx1-operator schar) . character)
117    (#.(%nx1-operator length) . fixnum)
118    (#.(%nx1-operator uvsize) . fixnum)
119    (#.(%nx1-operator %double-float/-2) . double-float)
120    (#.(%nx1-operator %double-float/-2!) . double-float) ; no such operator
121    (#.(%nx1-operator %double-float+-2) . double-float)
122    (#.(%nx1-operator %double-float+-2!) . double-float)
123    (#.(%nx1-operator %double-float--2) . double-float)
124    (#.(%nx1-operator %double-float--2!) . double-float)
125    (#.(%nx1-operator %double-float*-2) . double-float)
126    (#.(%nx1-operator %double-float*-2!) . double-float)
127   ))
128
129(defparameter *nx-operator-result-types-by-name*
130  '((%ilognot . fixnum)
131    (%ilogxor . fixnum)
132    (%ilogand . fixnum)
133    (%ilogior . fixnum)))
134
135(setq *nx-known-declarations*
136  '(special inline notinline type ftype function ignore optimize dynamic-extent ignorable
137    ignore-if-unused settable unsettable
138     notspecial global-function-name debugging-function-name resident))
139
140(defun find-optimize-quantity (name env)
141  (let ((pair ()))
142    (loop
143      (when (listp env) (return))
144      (when (setq pair (assq name (lexenv.mdecls env)))
145        (return (%cdr pair)))
146      (setq env (lexenv.parent-env env)))))
147   
148(defun debug-optimize-quantity (env)
149  (or (find-optimize-quantity 'debug env)
150      *nx-debug*))
151
152(defun space-optimize-quantity (env)
153  (or (find-optimize-quantity 'space env)
154      *nx-space*))
155
156(defun safety-optimize-quantity (env)
157  (or (find-optimize-quantity 'safety env)
158      *nx-safety*))
159
160(defun speed-optimize-quantity (env)
161  (or (find-optimize-quantity 'speed env)
162      *nx-speed*))
163
164(defun compilation-speed-optimize-quantity (env)
165  (or (find-optimize-quantity 'compilation-speed env)
166      *nx-cspeed*))
167
168(defvar *nx-speed* 1)
169(defvar *nx-space* 1)
170(defvar *nx-safety* 1)
171(defvar *nx-cspeed* 1)
172(defvar *nx-debug* 1)
173(defvar *nx-ignore-if-unused* ())
174(defvar *nx-new-p2decls* ())
175(defvar *nx-inlined-self* t)
176(defvar *nx-all-vars* nil)
177(defvar *nx-bound-vars* nil)
178(defvar *nx-punted-vars* nil)
179(defvar *nx-inline-expansions* nil)
180(defparameter *nx-compile-time-compiler-macros* nil)
181(defvar *nx-global-function-name* nil)
182(defvar *nx-can-constant-fold* ())
183(defvar *nx-synonyms* ())
184(defvar *nx-load-time-eval-token* ())
185
186(define-condition compiler-function-overflow (condition) ())
187
188(defun compiler-function-overflow ()
189  (signal 'compiler-function-overflow)
190  (error "Function size exceeds compiler limitation."))
191
192(defvar *compiler-macros* (make-hash-table :size 100 :test #'eq))
193
194; Just who was responsible for the "FUNCALL" nonsense ?
195; Whoever it is deserves a slow and painful death ...
196
197(defmacro define-compiler-macro  (name arglist &body body &environment env)
198  "Define a compiler-macro for NAME."
199  (unless (symbolp name) (report-bad-arg name 'symbol))
200  (let ((body (parse-macro-1 name arglist body env)))
201    `(eval-when (:compile-toplevel :load-toplevel :execute)
202       (setf (compiler-macro-function ',name)
203             (nfunction (compiler-macro-function ,name) ,body))         
204       ',name)))
205
206; This is silly (as may be the whole idea of actually -using- compiler-macros).
207; Compiler-macroexpand-1 will return a second value of  NIL if the value returned
208; by the expansion function is EQ to the original form.
209; This differs from the behavior of macroexpand-1, but users are not encouraged
210; to write macros which return their &whole args (as the DEFINE-COMPILER-MACRO
211; issue encourages them to do ...)
212; Cheer up! Neither of these things have to exist!
213(defun compiler-macroexpand-1 (form &optional env)
214  (let ((expander nil)
215        (newdef nil))
216    (if (and (consp form)
217             (symbolp (car form))
218             (setq expander (compiler-macro-function (car form) env)))
219      (values (setq newdef (funcall *macroexpand-hook* expander form env)) (neq newdef form))
220      (values form nil))))
221
222; ... If this exists, it should probably be exported.
223(defun compiler-macroexpand (form &optional env)
224  (multiple-value-bind (new win) (compiler-macroexpand-1 form env)
225    (do* ((won-at-least-once win))
226         ((null win) (values new won-at-least-once))
227      (multiple-value-setq (new win) (compiler-macroexpand-1 new env)))))
228
229
230
231
232(defun compiler-macro-function (name &optional env)
233  "If NAME names a compiler-macro in ENV, return the expansion function, else
234   return NIL. Can be set with SETF when ENV is NIL."
235  (unless (nx-lexical-finfo name env)
236    (or (cdr (assq name *nx-compile-time-compiler-macros*))
237        (values (gethash name *compiler-macros*)))))
238
239(defun set-compiler-macro-function (name def)
240  (unless (symbolp name) (report-bad-arg name 'symbol))
241  (if def
242    (setf (gethash name *compiler-macros*) def)
243    (remhash name *compiler-macros*))
244  def)
245
246(defsetf compiler-macro-function set-compiler-macro-function)
247
248(defparameter *nx-add-xref-entry-hook* nil
249  "When non-NIL, assumed to be a function of 3 arguments
250which asserts that the specied relation from the current
251function to the indicated name is true.")
252
253;; Cross-referencing
254(defun nx-record-xref-info (relation name)
255  (when (fboundp '%add-xref-entry)
256    (funcall '%add-xref-entry relation *nx-cur-func-name* name)))
257
258
259
260(defun nx-apply-env-hook (hook env &rest args)
261  (declare (dynamic-extent args))
262  (when (fixnump hook) (setq hook (uvref *nx-current-compiler-policy* hook)))
263  (if hook
264    (if (functionp hook)
265      (apply hook env args)
266      t)))
267
268(defun nx-self-calls-inlineable (env)
269  (nx-apply-env-hook policy.inline-self-calls env))
270
271(defun nx-allow-register-allocation (env)
272  (not (nx-apply-env-hook policy.inhibit-register-allocation env)))
273
274(defun nx-trust-declarations (env)
275  (unless (eq (safety-optimize-quantity env) 3)
276    (nx-apply-env-hook policy.trust-declarations env)))
277
278(defun nx-open-code-in-line (env)
279  (nx-apply-env-hook policy.open-code-inline env))
280
281(defun nx-inline-car-cdr (env)
282  (unless (eq (safety-optimize-quantity env) 3)
283    (nx-apply-env-hook policy.inhibit-safety-checking env)))
284
285(defun nx-inhibit-safety-checking (env)
286  (unless (eq (safety-optimize-quantity env) 3)
287    (nx-apply-env-hook policy.inhibit-safety-checking env)))
288
289(defun nx-tailcalls (env)
290  (nx-apply-env-hook policy.allow-tail-recursion-elimination env))
291
292(defun nx-allow-transforms (env)
293  (nx-apply-env-hook policy.allow-transforms env))
294
295(defun nx-inhibit-eventchecks (env)
296  (unless (eq (safety-optimize-quantity env) 3)
297    (nx-apply-env-hook policy.inhibit-event-checking env)))
298
299(defun nx-force-boundp-checks (var env)
300  (or (eq (safety-optimize-quantity env) 3)
301      (nx-apply-env-hook policy.force-boundp-checks var env)))
302
303(defun nx-substititute-constant-value (symbol value env)
304  (nx-apply-env-hook policy.allow-constant-substitution symbol value env))
305
306#-bccl
307(defun nx1-default-operator ()
308 (or (gethash *nx-sfname* *nx1-operators*)
309     (error "Bug - operator not found for  ~S" *nx-sfname*)))
310
311(defun nx-new-temp-var (pending &optional (pname "COMPILER-VAR"))
312  (let ((var (nx-new-var pending (make-symbol pname))))
313    (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
314                                   (%ilsl $vbittemporary 1)
315                                   (nx-var-bits var)))
316    var))
317
318(defun nx-new-vdecl (pending name class &optional info)
319  (push (cons name (cons class info)) (pending-declarations-vdecls pending)))
320
321(defun nx-new-fdecl (pending name class &optional info)
322  (push (cons name (cons class info)) (pending-declarations-fdecls pending)))
323
324(defun nx-new-var (pending sym &optional (check t))
325  (nx-init-var pending (nx-cons-var (nx-need-var sym check) 0)))
326                   
327(defun nx-proclaimed-special-p (sym)
328  (setq sym (nx-need-sym sym))
329  (let* ((defenv (definition-environment *nx-lexical-environment*))
330         (specials (if defenv (defenv.specials defenv))))
331    (or (assq sym specials)
332        (proclaimed-special-p sym))))
333
334(defun nx-proclaimed-parameter-p (sym)
335  (or (constantp sym)
336      (multiple-value-bind (special-p info) (nx-lex-info sym t)
337        (or 
338         (and (eq special-p :special) info)
339         (let* ((defenv (definition-environment *nx-lexical-environment*)))
340           (if defenv 
341             (or (%cdr (assq sym (defenv.specials defenv)))
342                 (assq sym (defenv.constants defenv)))))))))
343
344(defun nx-process-declarations (pending decls &optional (env *nx-lexical-environment*) &aux s f)
345  (dolist (decl decls pending)
346    (dolist (spec (%cdr decl))
347      (if (memq (setq s (car spec)) *nx-known-declarations*)
348        (if (setq f (getf *nx-standard-declaration-handlers* s))
349          (funcall f pending spec env))
350        ; Any type name is now (ANSI CL) a valid declaration.
351        ; We should probably do something to distinguish "type names" from "typo names",
352        ; so that (declare (inliMe foo)) warns unless the compiler has some reason to
353        ; believe that 'inliMe' (inlemon) has been DEFTYPEd.
354        (dolist (var (%cdr spec))
355          (if (symbolp var)
356            (nx-new-vdecl pending var 'type s)))))))
357
358; Put all variable decls for the symbol VAR into effect in environment ENV.  Now.
359; Returns list of all new vdecls pertaining to VAR.
360(defun nx-effect-vdecls (pending var env)
361  (let ((vdecls (lexenv.vdecls env))
362        (own nil))
363    (dolist (decl (pending-declarations-vdecls pending) (setf (lexenv.vdecls env) vdecls))
364      (when (eq (car decl) var) 
365        (when (eq (cadr decl) 'type)
366          (let* ((newtype (cddr decl))
367                 (merged-type (nx1-type-intersect var newtype (nx-declared-type var env))))
368             (unless (eq merged-type newtype)
369              (rplacd (cdr decl) merged-type))))
370        (push decl vdecls)
371        (push (cdr decl) own)))
372    own))
373
374
375(defun nx1-typed-var-initform (pending sym form &optional (env *nx-lexical-environment*))
376  (let* ((type t)
377         (*nx-form-type* (if (nx-trust-declarations env)
378                           (dolist (decl (pending-declarations-vdecls pending)  type)
379                            (when (and (eq (car decl) sym) (eq (cadr decl) 'type))
380                              (setq type (nx1-type-intersect sym type (cddr decl)))))
381                           t)))
382    (nx1-typed-form form env)))
383
384; Guess.
385(defun nx-effect-fdecls (pending var env)
386  (let ((fdecls (lexenv.fdecls env))
387        (own nil))
388    (dolist (decl (pending-declarations-fdecls pending) (setf (lexenv.fdecls env) fdecls))
389      (when (eq (car decl) var) 
390        (push decl fdecls)
391        (push (cdr decl) own)))
392    own))
393
394
395
396
397(defun nx-acode-form-typep (form type env)
398  (acode-form-typep form type  (nx-trust-declarations env)))
399
400(defun acode-form-typep (form type trust-decls)
401  (if (acode-p form)
402    (let* ((op (acode-operator form))
403           (opval-p (or (eq op (%nx1-operator fixnum)) (eq op (%nx1-operator immediate))))
404           (optype (and trust-decls
405                        (if (eq op (%nx1-operator typed-form)) 
406                          (%cadr form)
407                          (if (eq op (%nx1-operator lexical-reference))
408                            (var-inittype (%cadr form))
409                            (cdr (assq op *nx-operator-result-types*)))))))
410      (values
411       (if optype 
412         (subtypep optype type)
413         (if opval-p (typep (%cadr form) type)))))))
414
415(defun nx-acode-form-type (form env)
416  (acode-form-type form (nx-trust-declarations env)))
417
418(defun acode-form-type (form trust-decls)
419  (if (acode-p form)
420    (let* ((op (acode-operator form)))
421      (if (eq op (%nx1-operator fixnum))
422        'fixnum
423        (if (eq op (%nx1-operator immediate))
424          (type-of (%cadr form))
425          (and trust-decls
426               (if (eq op (%nx1-operator typed-form))
427                 (%cadr form)
428                 (cdr (assq op *nx-operator-result-types*)))))))))
429
430(defun acode-punted-var-p (var)
431  (let ((bits (nx-var-bits var)))
432    (and (%ilogbitp $vbitpunted bits)
433         (not (%ilogbitp $vbitspecial bits)))))
434
435; Strip off any type info or "punted" lexical references.
436; ??? Is it true that the "value" of the punted reference is unwrapped ? ???
437(defun acode-unwrapped-form (form) 
438  (while (and (consp (setq form (nx-untyped-form form)))
439           (eq (%car form) (%nx1-operator lexical-reference))
440           (acode-punted-var-p (cadr form)))
441    (setq form (var-ea (cadr form))))
442  form)
443
444(defun acode-fixnum-form-p (x)
445  (setq x (acode-unwrapped-form x))
446  (if (acode-p x)
447    (if (eq (acode-operator x) (%nx1-operator fixnum)) 
448      (cadr x))))
449
450(defun acode-integer-constant-p (x bits)
451  (let* ((int (or (acode-fixnum-form-p x)
452                  (progn
453                    (setq x (acode-unwrapped-form x))
454                    (if (acode-p x)
455                      (if (and (eq (acode-operator x) (%nx1-operator immediate))
456                               (typep (cadr x) 'fixnum))
457                        (cadr x)))))))
458    (and int
459         (or
460           (typep int `(signed-byte ,bits))
461           (typep int `(unsigned-byte ,bits)))
462         int)))
463
464(defun nx-lookup-target-uvector-subtag (name)
465  (or (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
466      (nx-error "Type ~s not supported on target ~s"
467                name (backend-target-arch-name *target-backend*))))
468
469(defun nx-target-uvector-subtag-name (subtag)
470  (or (car (rassoc subtag (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
471      (nx-error "Subtag ~s not native on target ~s"
472                subtag (backend-target-arch-name *target-backend*))))
473
474(defun acode-s16-constant-p (x)
475  (setq x (acode-unwrapped-form x))
476  (if (acode-p x)
477    (let* ((op (acode-operator x)))
478      (if (eql op (%nx1-operator fixnum))
479        (let* ((val (cadr x)))
480          (if (target-word-size-case
481               (32 (typep val '(signed-byte #.(- 16 2))))
482               (64 (typep val '(signed-byte #.(- 16 3)))))
483            (ash val (target-word-size-case
484                      (32 2)
485                      (64 3)))))
486        (if (eql op (%nx1-operator %unbound-marker))
487          (arch::target-unbound-marker-value
488           (backend-target-arch *target-backend*))
489          (if (eql op (%nx1-operator %slot-unbound-marker))
490            (arch::target-slot-unbound-marker-value
491             (backend-target-arch *target-backend*))))))))
492
493(defun acode-s32-constant-p (x)
494  (setq x (acode-unwrapped-form x))
495  (if (acode-p x)
496    (let* ((op (acode-operator x)))
497      (if (eql op (%nx1-operator fixnum))
498        (let* ((val (cadr x)))
499          (if (target-word-size-case
500               (32 (typep val '(signed-byte #.(- 32 2))))
501               (64 (typep val '(signed-byte #.(- 32 3)))))
502            (ash val (target-word-size-case
503                      (32 2)
504                      (64 3)))))
505        (if (eql op (%nx1-operator %unbound-marker))
506          (arch::target-unbound-marker-value
507           (backend-target-arch *target-backend*))
508          (if (eql op (%nx1-operator %slot-unbound-marker))
509            (arch::target-slot-unbound-marker-value
510             (backend-target-arch *target-backend*))))))))
511
512(defun acode-fixnum-type-p (form trust-decls)
513  (or (acode-fixnum-form-p form)
514      (and trust-decls
515           (acode-p form)
516           (eq (acode-operator form) (%nx1-operator typed-form))
517           (subtypep (cadr form) 'fixnum))))
518
519
520(defun nx-acode-fixnum-type-p (form env)
521    (acode-fixnum-type-p form (nx-trust-declarations env)))
522
523; Is acode-expression the result of alphatizing (%int-to-ptr <integer>) ?
524(defun acode-absolute-ptr-p (acode-expression &optional skip)
525  (and (acode-p acode-expression)
526       (or skip (prog1 (eq (acode-operator acode-expression) (%nx1-operator %macptrptr%))
527                  (setq acode-expression (%cadr acode-expression))))
528       (eq (acode-operator acode-expression) (%nx1-operator %consmacptr%))
529       (eq (acode-operator (setq acode-expression (%cadr acode-expression))) 
530           (%nx1-operator %immediate-int-to-ptr))
531       (let ((op (acode-operator (setq acode-expression (%cadr acode-expression)))))
532         (if (or (eq op (%nx1-operator fixnum))
533                 (and (eq op (%nx1-operator immediate))
534                      (integerp (%cadr acode-expression))))
535           (%cadr acode-expression)))))
536
537(defun nx-effect-other-decls (pending env)
538  (flet ((merge-decls (new old)
539                      (dolist (decl new old) (pushnew decl old :test #'eq))))
540    (let ((vdecls (pending-declarations-vdecls pending))
541          (fdecls (pending-declarations-fdecls pending))
542          (mdecls (pending-declarations-mdecls pending)))
543      (when vdecls
544        (let ((env-vdecls (lexenv.vdecls env)))
545          (dolist (decl vdecls (setf (lexenv.vdecls env) env-vdecls))
546            (unless (memq decl env-vdecls)
547              (when (eq (cadr decl) 'type)
548                (let* ((var (car decl))
549                       (newtype (cddr decl))
550                       (merged-type (nx1-type-intersect var newtype (nx-declared-type var env))))
551                  (unless (eq merged-type newtype)
552                    (rplacd (cdr decl) merged-type))))
553              (push decl env-vdecls)))))
554      (when fdecls (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.vdecls env))))
555      (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env))))
556      (setq *nx-inlined-self* (and (nx-self-calls-inlineable env) 
557                                   (let ((name *nx-global-function-name*)) 
558                                     (and name (not (nx-declared-notinline-p name env))))))
559      (unless (nx-allow-register-allocation env)
560        (nx-inhibit-register-allocation))
561      (setq *nx-new-p2decls* 
562            (%ilogior 
563             (if (nx-tailcalls env) $decl_tailcalls 0)
564             (if (nx-inhibit-eventchecks env) $decl_eventchk 0)
565             (if (nx-open-code-in-line env) $decl_opencodeinline 0)
566             (if (nx-inhibit-safety-checking env) $decl_unsafe 0)
567             (if (nx-trust-declarations env) $decl_trustdecls 0))))))
568
569#|     
570(defun nx-find-misc-decl (declname env)
571  (loop
572    (unless (and env (eq (uvref env 0) 'lexical-environment)) (return))
573    (dolist (mdecl (lexenv.mdecls env))
574      (if (atom mdecl)
575        (if (eq mdecl declname)
576          (return-from nx-find-misc-decl t))
577        (if (eq (%car mdecl) declname)
578          (return-from nx-find-misc-decl (%cdr mdecl)))))
579    (setq env (lexenv.parent-env env))))
580|#
581
582
583(defun nx-bad-decls (decls)
584  (nx1-whine :unknown-declaration decls))
585
586
587
588(defnxdecl special (pending decl env)
589  (declare (ignore env))
590  (dolist (s (%cdr decl))
591    (if (symbolp s) 
592      (nx-new-vdecl pending s 'special)
593      (nx-bad-decls decl))))
594
595(defnxdecl dynamic-extent (pending decl env)
596  (declare (ignore env))
597  (dolist (s (%cdr decl))
598    (if (symbolp s) 
599      (nx-new-vdecl pending s 'dynamic-extent t)
600      (if (and (consp s)
601               (eq (%car s) 'function)
602               (consp (%cdr s))
603               (symbolp (setq s (%cadr s))))
604        (nx-new-fdecl pending s 'dynamic-extent t)
605        (nx-bad-decls decl)))))
606
607(defnxdecl ignorable (pending decl env)
608  (declare (ignore env))
609  (dolist (s (%cdr decl))
610    (if (symbolp s) 
611      (nx-new-vdecl pending s 'ignore-if-unused t)
612      (if (and (consp s)
613               (eq (%car s) 'function)
614               (consp (%cdr s))
615               (symbolp (setq s (%cadr s))))
616        (nx-new-fdecl pending s 'ignore-if-unused t)
617        (nx-bad-decls decl)))))
618
619(defnxdecl ftype (pending decl env)
620  (declare (ignore env))
621  (destructuring-bind (type &rest fnames) (%cdr decl)
622    (dolist (s fnames)
623      (nx-new-fdecl pending s 'ftype type))))
624
625(defnxdecl settable (pending decl env)
626  (nx-settable-decls pending decl env t))
627
628(defnxdecl unsettable (pending decl env)
629  (nx-settable-decls pending decl env nil))
630
631(defun nx-settable-decls (pending decl env val)
632  (declare (ignore env))
633  (dolist (s (%cdr decl))
634    (if (symbolp s)
635      (nx-new-vdecl pending s 'settable val)
636      (nx-bad-decls decl))))
637
638(defnxdecl type (pending decl env)
639  (declare (ignore env))
640  (labels ((kludge (type) ; 0 => known, 1 => unknown, 2=> illegal
641             (cond ((type-specifier-p type)
642                    0)
643                   ((and (consp type)
644                         (member (car type) '(and or))
645                         (not (null (list-length type))))
646                    (do ((result 0 (max result (kludge (car tail))))
647                         (tail (cdr type) (cdr tail)))
648                        ((null tail)
649                         result)))
650                   ((not (symbolp type))
651                    ;;>>>> nx-bad-decls shouldn't signal a fatal error!!!!
652                    ;;>>>> Most callers of nx-bad-decls should just ignore the
653                    ;;>>>> losing decl element and proceed with the rest
654                    ;;>>>>  (ie (declare (ignore foo (bar) baz)) should
655                    ;;>>>>   have the effect of ignoring foo and baz as well
656                    ;;>>>>   as WARNING about the mal-formed declaration.)
657                    (nx-bad-decls decl)
658                    2)
659                   (t 1))))
660    (let* ((spec (%cdr decl))
661           (type (car spec)))
662      (case (kludge type)
663        ((0)
664         (dolist (sym (cdr spec))
665           (if (symbolp sym)
666             (nx-new-vdecl pending sym 'type type)
667             (nx-bad-decls decl))))
668        ((1)
669         (dolist (sym (cdr spec))
670           (unless (symbolp sym)
671             (nx-bad-decls decl))))
672        ((2)
673         (nx-bad-decls decl))))))
674
675
676
677(defnxdecl global-function-name (pending decl env)
678  (declare (ignore pending))
679  (when *nx-parsing-lambda-decls*
680    (let ((name (cadr decl)))
681      (setq *nx-global-function-name* (setf (afunc-name *nx-current-function*) name))
682      (setq *nx-inlined-self* (not (nx-declared-notinline-p name env))))))
683
684(defnxdecl debugging-function-name (pending decl env)
685  (declare (ignore pending env))
686  (when *nx-parsing-lambda-decls*
687    (setf (afunc-name *nx-current-function*) (cadr decl))))
688
689(defnxdecl resident (pending decl env)
690  (declare (ignore env pending))
691  (declare (ignore decl))
692  (nx-decl-set-fbit $fbitresident))
693
694
695(defun nx-inline-decl (pending decl val &aux valid-name)
696  (dolist (s (%cdr decl))
697    (multiple-value-setq (valid-name s) (valid-function-name-p s))
698    (if valid-name
699      (progn
700        (if (nx-self-call-p s nil t)
701          (setq *nx-inlined-self* val))
702        (nx-new-fdecl pending s 'inline (if val 'inline 'notinline)))
703      (nx-bad-decls decl))))
704
705(defnxdecl inline (pending decl env)
706  (declare (ignore env))
707  (nx-inline-decl pending decl t))
708
709(defnxdecl notinline (pending decl env)
710  (declare (ignore env))
711  (nx-inline-decl pending decl nil))
712
713(defnxdecl ignore (pending decl env)
714  (declare (ignore env))
715  (dolist (s (%cdr decl))
716    (if (symbolp s) 
717      (nx-new-vdecl pending s 'ignore t)
718      (nx-bad-decls decl))))
719
720(defnxdecl ignore-if-unused (pending decl env)
721  (declare (ignore env))
722  (dolist (s (%cdr decl))
723    (if (symbolp s) 
724      (nx-new-vdecl pending s 'ignore-if-unused)
725      (nx-bad-decls decl))))
726
727(defun nx-self-call-p (name &optional ignore-lexical (allow *nx-inlined-self*))
728  (when (and name (symbolp name))
729    (let ((current-afunc *nx-current-function*)
730          (target-afunc (unless ignore-lexical (nth-value 1 (nx-lexical-finfo name)))))
731      (or (eq current-afunc target-afunc)
732          (and allow
733               (eq name *nx-global-function-name*)
734               (null target-afunc)
735               (null (afunc-parent current-afunc)))))))
736
737(defun nx-check-var-usage (var)
738  (let* ((sym (var-name var))
739         (bits (nx-var-bits var))
740         (expansion (var-ea var))
741         (setqed (%ilogbitp $vbitsetq bits))
742         (reffed (%ilogbitp $vbitreffed bits))
743         (closed (%ilogbitp $vbitclosed bits))
744         (special (%ilogbitp $vbitspecial bits))
745         (ignored (%ilogbitp $vbitignore bits))
746         (ignoreunused (%ilogbitp $vbitignoreunused bits)))
747    (if (or special reffed closed)
748      (progn
749        (if ignored (nx1-whine :ignore sym))
750        (nx-set-var-bits var (%ilogand (nx-check-downward-vcell var bits) (%ilognot (%ilsl $vbitignore 1)))))
751      (progn
752        (if (and setqed ignored) (nx1-whine :ignore sym))
753        (or ignored ignoreunused 
754            (progn (and (consp expansion) (eq (car expansion) :symbol-macro) (setq sym (list :symbol-macro sym))) (nx1-whine :unused sym)))
755        (when (%izerop (%ilogand bits (%ilogior $vrefmask $vsetqmask)))
756          (nx-set-var-bits var (%ilogior (%ilsl $vbitignore 1) bits)))))))
757
758; if an inherited var isn't setqed, it gets no vcell.  If it -is- setqed, but
759; all inheritors are downward, the vcell can be stack-consed.  Set a bit so that
760; the right thing happens when the var is bound.
761; Set the bit for the next-method var even if it is not setqed.
762(defun nx-check-downward-vcell (v bits)
763  (if (and (%ilogbitp $vbitclosed bits)
764           (or (%ilogbitp $vbitsetq bits)
765               (eq v *nx-next-method-var*))
766           (nx-afuncs-downward-p v (afunc-inner-functions *nx-current-function*)))
767    (%ilogior (%ilsl $vbitcloseddownward 1) bits)
768    bits))
769
770; afunc is "downward wrt v" if it doesn't inherit v or if all refs to afunc
771; are "downward" and no inner function of afunc is not downward with respect to v.
772(defun nx-afunc-downward-p (v afunc)
773  (or (dolist (i (afunc-inherited-vars afunc) t)
774        (when (eq (nx-root-var i) v) (return nil)))
775      (if (nx-afuncs-downward-p v (afunc-inner-functions afunc))
776        (eq (afunc-fn-refcount afunc)
777            (afunc-fn-downward-refcount afunc)))))
778
779(defun nx-afuncs-downward-p (v afuncs)
780  (dolist (afunc afuncs t)
781    (unless (nx-afunc-downward-p v afunc) (return nil))))
782
783(defun nx1-punt-bindings (vars initforms)
784  (dolist (v vars)
785    (nx1-punt-var v (pop initforms))))
786
787; at the beginning of a binding construct, note which lexical variables are bound to other
788; variables and the number of setqs done so far on the initform.
789; After executing the body, if neither variable has been closed over,
790; the new variable hasn't been setq'ed, and the old guy wasn't setq'ed
791; in the body, the binding can be punted.
792(defun nx1-note-var-bindings (vars initforms &aux alist)
793  (dolist (var vars alist)
794    (let* ((binding (nx1-note-var-binding var (pop initforms))))
795      (if binding (push binding alist)))))
796
797(defun nx1-note-var-binding (var initform)
798  (let* ((init (nx-untyped-form initform))
799         (inittype (nx-acode-form-type initform *nx-lexical-environment*))
800         (bits (nx-var-bits var)))
801    (when (%ilogbitp $vbitspecial bits) (nx-record-xref-info :binds (var-name var)))
802    (when inittype (setf (var-inittype var) inittype))
803    (when (and (not (%ilogbitp $vbitspecial bits))
804               (consp init))
805      (let* ((op (acode-operator init)))
806        (if (eq op (%nx1-operator lexical-reference))
807          (let* ((target (%cadr init))
808                 (setq-count (%ilsr 8 (%ilogand $vsetqmask (nx-var-bits target)))))
809            (unless (eq setq-count (%ilsr 8 $vsetqmask))
810              (cons var (cons setq-count target))))
811          (if (and (%ilogbitp $vbitdynamicextent bits)
812                   (or (eq op (%nx1-operator closed-function))
813                       (eq op (%nx1-operator simple-function))))
814            (let* ((afunc (%cadr init)))
815              (setf (afunc-fn-downward-refcount afunc)
816                    (afunc-fn-refcount afunc)
817                    (afunc-bits afunc) (logior (ash 1 $fbitdownward) (ash 1 $fbitbounddownward)
818                                               (the fixnum (afunc-bits afunc))))
819              nil)))))))
820                     
821(defun nx1-check-var-bindings (alist)
822  (dolist (pair alist)
823    (let* ((var (car pair))
824           (target (cddr pair))
825           (vbits (nx-var-bits var))
826           (target-bits (nx-var-bits target)))
827      (unless (or
828               ; var can't be setq'ed or closed; target can't be setq'ed AND closed.
829               (neq (%ilogand vbits (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1))) 0)
830               (eq (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1)) 
831                   (%ilogand
832                     (%ilogior (%ilsl $vbitsetq 1) (%ilsl $vbitclosed 1))
833                     target-bits))
834               (neq (%ilsr 8 (%ilogand $vsetqmask target-bits)) (cadr pair)))
835             (push (cons var target) *nx-punted-vars*)))))
836
837(defun nx1-punt-var (var initform)
838  (let* ((bits (nx-var-bits var))
839         (mask (%ilogior (%ilsl $vbitsetq 1) (ash -1 $vbitspecial) (%ilsl $vbitclosed 1)))
840         ;(count (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits))))
841         (nrefs (%ilogand $vrefmask bits))
842         (val (nx-untyped-form initform))
843         (op (if (acode-p val) (acode-operator val))))
844    (when (%izerop (%ilogand mask bits))
845      (if
846        (or 
847         ;(%izerop count)  ; unreferenced vars can still have side effects
848         (nx-t val)
849         (nx-null val)
850         (and (eql nrefs 1) ( acode-absolute-ptr-p val t))
851         (eq op (%nx1-operator fixnum))
852         (eq op (%nx1-operator immediate)))
853        (nx-set-var-bits var (%ilogior (%ilsl $vbitpuntable 1) bits))))
854    (when (and (%ilogbitp $vbitdynamicextent bits)
855               (or (eq op (%nx1-operator closed-function))
856                   (eq op (%nx1-operator simple-function))))
857      (let* ((afunc (cadr val)))
858        (setf (afunc-bits afunc) (%ilogior (%ilsl $fbitbounddownward 1) (afunc-bits afunc))
859              (afunc-fn-downward-refcount afunc) 1))) 
860    nil))
861           
862(defnxdecl optimize (pending specs env)
863  (declare (ignore env))
864  (let* ((q nil)
865         (v nil)
866         (mdecls (pending-declarations-mdecls pending)))
867    (dolist (spec (%cdr specs) (setf (pending-declarations-mdecls pending) mdecls))
868      (if (atom spec)
869        (setq q spec v 3)
870        (setq q (%car spec) v (cadr spec)))
871      (if (and (fixnump v) (<= 0 v 3) (memq q '(speed space compilation-speed safety debug)))
872        (push (cons q v) mdecls)
873        (nx-bad-decls specs)))))
874
875(defun %proclaim-optimize (specs &aux q v)
876 (dolist (spec specs)
877  (if (atom spec)
878   (setq q spec v 3)
879   (setq q (%car spec) v (cadr spec)))
880  (when (and (fixnump v) (<= 0 v 3))
881   (if (eq q 'speed)
882    (setq *nx-speed* v)
883    (if (eq q 'space)
884     (setq *nx-space* v)
885     (if (eq q 'compilation-speed)
886      (setq *nx-cspeed* v)
887      (if (eq q 'safety)
888       (setq *nx-safety* v)
889       (if (eq q 'debug)
890         (setq *nx-debug* v)))))))))
891
892(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*))
893  (let* ((info nil)
894         (barrier-crossed nil))
895    (if env
896      (loop
897        (when (eq 'barrier (lexenv.variables env))
898          (setq barrier-crossed t))
899        (when (setq info (%cdr (assq sym (lexenv.functions env))))
900          (return (values info (if (and (eq (car info) 'function)
901                                        (consp (%cdr info)))
902                                 (progn
903                                   (when barrier-crossed
904                                     (nx-error "Illegal reference to lexically-defined function ~S." sym))
905                                   (%cadr info))))))
906        (if (listp (setq env (lexenv.parent-env env)))
907          (return (values nil nil))))
908      (values nil nil))))
909
910(defun nx-inline-expansion (sym &optional (env *nx-lexical-environment*) global-only)
911  (let* ((lambda-form nil)
912         (containing-env nil)
913         (token nil))
914    (if (and (nx-declared-inline-p sym env)
915             (not (gethash sym *nx1-alphatizers*)))
916      (multiple-value-bind (info afunc) (unless global-only (nx-lexical-finfo sym env))
917        (if info (setq token afunc 
918                       containing-env (afunc-environment afunc)
919                       lambda-form (afunc-lambdaform afunc)))
920        (let* ((defenv (definition-environment env)))
921          (if (cdr (setq info (if defenv (cdr (assq sym (defenv.defined defenv))))))
922            (setq lambda-form (cdr info)
923                  token sym
924                  containing-env (new-lexical-environment defenv))
925            (unless info
926              (if (cdr (setq info (assq sym *nx-globally-inline*)))
927                (setq lambda-form (%cdr info)
928                      token sym
929                      containing-env (new-lexical-environment (new-definition-environment nil)))))))))
930    (values lambda-form (nx-closed-environment env containing-env) token)))
931
932(defun nx-closed-environment (current-env target)
933  (when target
934    (let* ((intervening-functions nil))
935      (do* ((env current-env (lexenv.parent-env env)))
936           ((or (eq env target) (null env) (eq (%svref env 0) 'definition-environment)))
937        (let* ((fn (lexenv.lambda env)))
938          (when fn (push fn intervening-functions))))
939      (let* ((result target))
940        (dolist (fn intervening-functions result)
941          (setf (lexenv.lambda (setq result (new-lexical-environment result))) fn))))))
942
943(defun nx-root-var (v)
944  (do* ((v v bits)
945        (bits (var-bits v) (var-bits v)))
946       ((fixnump bits) v)))
947
948(defun nx-reconcile-inherited-vars (more)
949  (let ((last nil)) ; Bop 'til ya drop.
950    (loop
951      (setq last more more nil)
952      (dolist (callee last)
953        (dolist (caller (afunc-callers callee))
954          (unless (or (eq caller callee)
955                      (eq caller (afunc-parent callee)))
956            (dolist (v (afunc-inherited-vars callee))
957              (let ((root-v (nx-root-var v)))
958                (unless (dolist (caller-v (afunc-inherited-vars caller))
959                          (when (eq root-v (nx-root-var caller-v))
960                            (return t)))
961                  ; caller must inherit root-v in order to call callee without using closure.
962                  ; can't just bind afunc & call nx-lex-info here, 'cause caller may have
963                  ; already shadowed another var with same name.  So:
964                  ; 1) find the ancestor of callee which bound v; this afunc is also an ancestor
965                  ;    of caller
966                  ; 2) ensure that each afunc on the inheritance path from caller to this common
967                  ;    ancestor inherits root-v.
968                  (let ((ancestor (afunc-parent callee))
969                        (inheritors (list caller)))
970                    (until (eq (setq v (var-bits v)) root-v)
971                      (setq ancestor (afunc-parent ancestor)))
972                    (do* ((p (afunc-parent caller) (afunc-parent p)))
973                         ((eq p ancestor))
974                      (push p inheritors))
975                    (dolist (f inheritors)
976                      (setq v (nx-cons-var (var-name v) v))
977                      (unless (dolist (i (afunc-inherited-vars f))
978                                (when (eq root-v (nx-root-var i))
979                                  (return (setq v i))))
980                        (pushnew f more)
981                        (push v (afunc-inherited-vars f))
982                        ; change shared structure of all refs in acode with one swell foop.
983                        (nx1-afunc-ref f))))))))))   
984      (unless more (return)))))
985
986(defun nx-inherit-var (var binder current)
987  (if (eq binder current)
988    (progn
989      (nx-set-var-bits var (%ilogior2 (%ilsl $vbitclosed 1) (nx-var-bits var)))
990      var)
991    (let ((sym (var-name var)))
992      (or (dolist (already (afunc-inherited-vars current))
993            (when (eq sym (var-name already)) (return already)))
994          (progn
995            (setq var (nx-cons-var sym (nx-inherit-var var binder (afunc-parent current))))
996            (push var (afunc-inherited-vars current))
997            var)))))
998
999(defun nx-lex-info (sym &optional current-only)
1000  (let* ((current-function *nx-current-function*)
1001         (catch nil)
1002         (barrier-crossed nil))
1003    (multiple-value-bind 
1004      (info afunc)
1005      (do* ((env *nx-lexical-environment* (lexenv.parent-env env))
1006            (continue env (and env (neq (%svref env 0) 'definition-environment)))
1007            (binder current-function (or (if continue (lexenv.lambda env)) binder)))
1008           ((or (not continue) (and (neq binder current-function) current-only)) 
1009            (values nil nil))
1010        (let ((vars (lexenv.variables env)))
1011          (if (eq vars 'catch) 
1012            (setq catch t)
1013            (if (eq vars 'barrier)
1014              (setq barrier-crossed t)
1015              (let ((v (dolist (var vars)
1016                         (when (eq (var-name var) sym) (return var)))))
1017                (when v (return (values v binder)))
1018                (dolist (decl (lexenv.vdecls env))
1019                  (when (and (eq (car decl) sym)
1020                             (eq (cadr decl) 'special))
1021                    (return-from nx-lex-info (values :special nil nil)))))))))
1022      (if info
1023        (if (var-expansion info)
1024          (values :symbol-macro (cdr (var-expansion info)) info)
1025          (if (%ilogbitp $vbitspecial (nx-var-bits info))
1026            (values :special info nil)
1027            (if barrier-crossed
1028              (nx-error "Illegal reference to lexically defined variable ~S." sym)
1029              (if (eq afunc current-function)
1030                (values info nil catch)
1031                (values (nx-inherit-var info afunc current-function) t catch)))))
1032        (values nil nil nil)))))
1033
1034
1035(defun nx-block-info (blockname &optional (afunc *nx-current-function*) &aux
1036  blocks
1037  parent
1038  (toplevel (eq afunc *nx-current-function*))
1039  blockinfo)
1040 (when afunc
1041  (setq
1042   blocks (if toplevel *nx-blocks* (afunc-blocks afunc))
1043   blockinfo (assq blockname blocks)
1044   parent (afunc-parent afunc))
1045  (if blockinfo
1046   (values blockinfo nil)
1047   (when parent
1048    (when (setq blockinfo (nx-block-info blockname parent))
1049     (values blockinfo t))))))
1050
1051(defun nx-tag-info (tagname &optional (afunc *nx-current-function*) &aux
1052                            tags
1053                            parent
1054                            index
1055                            counter
1056                            (toplevel (eq afunc *nx-current-function*))
1057                            taginfo)
1058  (when afunc
1059    (setq
1060     tags (if toplevel *nx-tags* (afunc-tags afunc))
1061     taginfo (assoc tagname tags)
1062     parent (afunc-parent afunc))
1063    (if taginfo
1064      (values taginfo nil)
1065      (when (and parent (setq taginfo (nx-tag-info tagname parent)))
1066        (unless (setq index (cadr taginfo))
1067          (setq counter (caddr taginfo))
1068          (%rplaca counter (%i+ (%car counter) 1))
1069          (setq index (%car counter))
1070          (%rplaca (%cdr taginfo) index))
1071        (values taginfo index)))))
1072
1073(defun nx1-transitively-punt-bindings (pairs) 
1074  (dolist (pair (nreverse pairs))
1075    (let* ((var         (%car pair))
1076           (boundto     (%cdr pair))
1077           (varbits     (nx-var-bits var))
1078           (boundtobits (nx-var-bits boundto)))
1079      (declare (fixnum varbits boundtobits))
1080
1081      (unless (eq (%ilogior
1082                    (%ilsl $vbitsetq 1)
1083                    (%ilsl $vbitclosed 1))
1084                  (%ilogand
1085                    (%ilogior
1086                      (%ilsl $vbitsetq 1)
1087                      (%ilsl $vbitclosed 1))
1088                    boundtobits))
1089        ; Can't happen -
1090        (unless (%izerop (%ilogand (%ilogior
1091                                     (%ilsl $vbitsetq 1) 
1092                                     (ash -1 $vbitspecial)
1093                                     (%ilsl $vbitclosed 1)) varbits))
1094          (error "Bug-o-rama - \"punted\" var had bogus bits. ~
1095Or something. Right? ~s ~s" var varbits))
1096        (let* ((varcount     (%ilogand $vrefmask varbits)) 
1097               (boundtocount (%ilogand $vrefmask boundtobits)))
1098          (nx-set-var-bits var (%ilogior
1099                                 (%ilsl $vbitpuntable 1)
1100                                 (%i- varbits varcount)))
1101              (nx-set-var-bits
1102               boundto
1103                 (%i+ (%i- boundtobits boundtocount)
1104                      (%ilogand $vrefmask
1105                                (%i+ (%i- boundtocount 1) varcount)))))))))
1106
1107(defun nx1-compile-lambda (name lambda-form &optional
1108                                 (p (make-afunc))
1109                                 q
1110                                 parent-env
1111                                 (policy *default-compiler-policy*)
1112                                 load-time-eval-token)
1113  (if q
1114     (setf (afunc-parent p) q))
1115  (setf (afunc-name p) name)
1116  (unless (lambda-expression-p lambda-form)
1117    (nx-error "~S is not a valid lambda expression." lambda-form))
1118  (let* ((*nx-current-function* p)
1119         (*nx-parent-function* q)
1120         (*nx-lexical-environment* (new-lexical-environment parent-env))
1121         (*nx-load-time-eval-token* load-time-eval-token)
1122         (*nx-all-vars* nil)
1123         (*nx-bound-vars* nil)
1124         (*nx-punted-vars* nil)
1125         (*nx-current-compiler-policy* policy)
1126         (*nx-blocks* nil)
1127         (*nx-tags* nil)
1128         (*nx-loop-nesting-level* 0)
1129         (*nx-inner-functions* nil)
1130         (*nx-global-function-name* nil)
1131         (*nx-warnings* nil)
1132         (*nx1-fcells* nil)
1133         (*nx1-vcells* nil)
1134         (*nx-inline-expansions* nil)
1135         (*nx-parsing-lambda-decls* nil)
1136         (*nx-next-method-var* (if q *nx-next-method-var*))
1137         (*nx-call-next-method-function* (if q *nx-call-next-method-function*))
1138         (*nx-cur-func-name* (or (and (method-lambda-p lambda-form) *nx-method-warning-name*)
1139                                name)))
1140    (if (%non-empty-environment-p *nx-lexical-environment*)
1141      (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p)))))
1142    (multiple-value-bind (body decls)
1143                         (parse-body (%cddr lambda-form) *nx-lexical-environment* t)
1144      (setf (afunc-lambdaform p) lambda-form)
1145      (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))
1146      (nx1-transitively-punt-bindings *nx-punted-vars*)
1147      (setf (afunc-blocks p) *nx-blocks*)
1148      (setf (afunc-tags p) *nx-tags*)
1149      (setf (afunc-inner-functions p) *nx-inner-functions*)
1150      (setf (afunc-all-vars p) *nx-all-vars*)
1151      (setf (afunc-vcells p) *nx1-vcells*)
1152      (setf (afunc-fcells p) *nx1-fcells*)
1153      (let* ((warnings (merge-compiler-warnings *nx-warnings*))
1154             (name *nx-cur-func-name*))       
1155        (dolist (inner *nx-inner-functions*)
1156          (dolist (w (afunc-warnings inner))
1157            (push name (compiler-warning-function-name w))
1158            (push w warnings)))
1159        (setf (afunc-warnings p) warnings))
1160      p)))
1161
1162(defun method-lambda-p (form)
1163  (and (consp form)
1164       (consp (setq form (%cdr form)))       
1165       (eq (caar form) '&method)))
1166         
1167
1168
1169
1170
1171
1172(defun nx1-lambda (ll body decls &aux (l ll) methvar)
1173  (let ((old-env *nx-lexical-environment*)
1174        (*nx-bound-vars* *nx-bound-vars*))
1175    (with-nx-declarations (pending)
1176      (let* ((*nx-parsing-lambda-decls* t))
1177        (nx-process-declarations pending decls))
1178      (when (eq (car l) '&lap)
1179        (let ((bits nil))
1180          (unless (and (eq (length (%cdr l)) 1) (fixnump (setq bits (%cadr l))))
1181            (unless (setq bits (encode-lambda-list (%cdr l)))
1182              (nx-error "invalid lambda-list  - ~s" l)))
1183          (return-from nx1-lambda
1184                       (list
1185                        (%nx1-operator lambda-list)
1186                        (list (cons '&lap bits))
1187                        nil
1188                        nil
1189                        nil
1190                        nil
1191                        (nx1-env-body body old-env)
1192                        *nx-new-p2decls*))))
1193      (when (eq (car l) '&method)
1194        (setf (afunc-bits *nx-current-function*)
1195              (%ilogior (%ilsl $fbitmethodp 1)
1196                        (afunc-bits *nx-current-function*)))
1197        (setq *nx-inlined-self* nil)
1198        (setq *nx-next-method-var* (setq methvar (let ((var (nx-new-var
1199                                                             pending
1200                                                             (%cadr ll))))
1201                                                   (nx-set-var-bits var (%ilogior 
1202                                                                          (%ilsl $vbitignoreunused 1) 
1203                                                                          ;(%ilsl $vbitnoreg 1)
1204                                                                          (nx-var-bits var)))
1205                                                   var)))
1206                                                   
1207        (setq ll (%cddr ll)))
1208      (multiple-value-bind (req opt rest keys auxen lexpr)
1209                           (nx-parse-simple-lambda-list pending ll)
1210        (nx-effect-other-decls pending *nx-lexical-environment*)
1211        (setq body (nx1-env-body body old-env))
1212        (nx1-punt-bindings (%car auxen) (%cdr auxen))         
1213        (when methvar
1214          (push methvar req)
1215          (unless (eq 0 (%ilogand (%ilogior (%ilsl $vbitreffed 1)
1216                                            (%ilsl $vbitclosed 1)
1217                                            (%ilsl $vbitsetq 1))
1218                                  (nx-var-bits methvar)))
1219            (setf (afunc-bits *nx-current-function*)
1220                  (%ilogior 
1221                   (%ilsl $fbitnextmethp 1)
1222                   (afunc-bits *nx-current-function*)))))
1223        (make-acode
1224         (%nx1-operator lambda-list) 
1225         req
1226         opt 
1227         (if lexpr (list rest) rest)
1228         keys
1229         auxen
1230         body
1231         *nx-new-p2decls*)))))
1232 
1233(defun nx-parse-simple-lambda-list (pending ll &aux
1234                                              req
1235                                              opt
1236                                              rest
1237                                              keys
1238                                              lexpr
1239                                              sym)
1240  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail)
1241                       (verify-lambda-list ll)
1242    (unless ok (nx-error "Bad lambda list : ~S" ll))
1243    (dolist (var reqsyms)
1244      (push (nx-new-var pending var t) req))
1245    (when (eq (pop opttail) '&optional)
1246      (let* (optvars optinits optsuppliedp)
1247        (until (eq opttail resttail) 
1248          (setq sym (pop opttail))
1249          (let* ((var sym)
1250                 (initform nil)
1251                 (spvar nil))
1252            (when (consp var)
1253              (setq sym (pop var) initform (pop var) spvar (%car var)))
1254            (push (nx1-typed-var-initform pending sym initform) optinits)
1255            (push (nx-new-var pending sym t) optvars)
1256            (push (if spvar (nx-new-var pending spvar t)) optsuppliedp)))
1257        (if optvars
1258          (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
1259          (nx1-whine :lambda ll))))
1260    (let ((temp (pop resttail)))
1261      (when (or (eq temp '&rest)
1262                (setq lexpr (eq temp '&lexpr)))
1263        (setq rest (nx-new-var pending (%car resttail) t))))
1264    (when (eq (%car keytail) '&key) 
1265      (setq keytail (%cdr keytail))
1266      (let* ((keysyms ())
1267             (keykeys ())
1268             (keyinits ())
1269             (keysupp ())
1270             (kallowother (not (null (memq '&allow-other-keys ll))))
1271             (kvar ())
1272             (kkey ())
1273             (kinit ())
1274             (ksupp))
1275        (until (eq keytail auxtail)
1276          (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
1277            (setq kinit *nx-nil* ksupp nil)
1278            (if (atom sym)
1279              (setq kvar sym kkey (make-keyword sym))
1280              (progn
1281                (if (consp (%car sym))
1282                  (setq kkey (%caar sym) kvar (%cadar sym))
1283                  (progn
1284                    (setq kvar (%car sym))
1285                    (setq kkey (make-keyword kvar))))
1286                (setq kinit (nx1-typed-var-initform pending kvar (%cadr sym)))
1287                (setq ksupp (%caddr sym))))
1288            (push (nx-new-var pending kvar t) keysyms)
1289            (push kkey keykeys)
1290            (push kinit keyinits)
1291            (push (if ksupp (nx-new-var pending ksupp t)) keysupp)))
1292        (setq 
1293         keys
1294         (list
1295          kallowother
1296          (nreverse keysyms)
1297          (nreverse keysupp)
1298          (nreverse keyinits)
1299          (apply #'vector (nreverse keykeys))))))
1300    (let (auxvals auxvars)
1301      (dolist (pair (%cdr auxtail))
1302        (let* ((auxvar (nx-pair-name pair))
1303               (auxval (nx1-typed-var-initform pending auxvar (nx-pair-initform pair))))
1304          (push auxval auxvals)
1305          (push (nx-new-var pending auxvar t) auxvars)))
1306      (values
1307       (nreverse req) 
1308       opt 
1309       rest
1310       keys
1311       (list (nreverse auxvars) (nreverse auxvals))
1312       lexpr))))
1313
1314(defun nx-new-structured-var (pending sym)
1315  (if sym
1316    (nx-new-var pending sym t)
1317    (nx-new-temp-var pending)))
1318
1319(defun nx-parse-structured-lambda-list (pending ll &optional no-acode whole-p &aux
1320                                           req
1321                                           opt
1322                                           rest
1323                                           keys
1324                                           sym)
1325  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail all whole structured-p)
1326                       (verify-lambda-list ll t whole-p nil)
1327    (declare (ignore all))
1328    (unless ok (nx-error "Bad lambda list : ~S" ll))
1329    (if (or whole (and whole-p structured-p)) (setq whole (nx-new-structured-var pending whole)))
1330    (dolist (var reqsyms)
1331      (push (if (symbolp var)
1332                    (nx-new-structured-var pending var)
1333                    (nx-structured-lambda-form pending var no-acode))
1334                  req))
1335    (when (eq (pop opttail) '&optional)
1336      (let* (optvars optinits optsuppliedp)
1337        (until (eq opttail resttail) 
1338          (setq sym (pop opttail))
1339          (let* ((var sym)
1340                 (initform nil)
1341                 (spvar nil))
1342            (when (consp var)
1343              (setq sym (pop var) initform (pop var) spvar (%car var)))
1344            (push (if no-acode initform (nx1-form initform)) optinits)
1345            (push (if (symbolp sym)
1346                          (nx-new-structured-var pending sym)
1347                          (nx-structured-lambda-form pending sym no-acode))
1348                        optvars)
1349            (push (if spvar (nx-new-var pending spvar)) optsuppliedp)))
1350        (if optvars
1351          (setq opt (list (nreverse optvars) (nreverse optinits) (nreverse optsuppliedp)))
1352          (nx1-whine :lambda ll))))
1353    (let ((var (pop resttail)))
1354      (when (or (eq var '&rest)
1355                (eq var '&body))
1356        (setq var (pop resttail)
1357              rest (if (symbolp var)
1358                     (nx-new-structured-var pending var)
1359                     (nx-structured-lambda-form pending var no-acode)))))
1360    (when (eq (%car keytail) '&key) 
1361      (setq keytail (%cdr keytail))
1362      (let* ((keysyms ())
1363             (keykeys ())
1364             (keyinits ())
1365             (keysupp ())
1366             (kallowother (not (null (memq '&allow-other-keys ll))))
1367             (kvar ())
1368             (kkey ())
1369             (kinit ())
1370             (ksupp))
1371        (until (eq keytail auxtail)
1372          (unless (eq (setq sym (pop keytail)) '&allow-other-keys)     
1373            (setq kinit *nx-nil* ksupp nil)
1374            (if (atom sym)
1375              (setq kvar sym kkey (make-keyword sym))
1376              (progn
1377                (if (consp (%car sym))
1378                  (setq kkey (%caar sym) kvar (%cadar sym))
1379                  (progn
1380                    (setq kvar (%car sym))
1381                    (setq kkey (make-keyword kvar))))
1382                (setq kinit (if no-acode (%cadr sym) (nx1-form (%cadr sym))))
1383                (setq ksupp (%caddr sym))))
1384            (push (if (symbolp kvar)
1385                          (nx-new-structured-var pending kvar)
1386                          (nx-structured-lambda-form pending kvar no-acode))
1387                        keysyms)
1388            (push kkey keykeys)
1389            (push kinit keyinits)
1390            (push (if ksupp (nx-new-var pending ksupp)) keysupp)))
1391        (setq 
1392         keys
1393         (list
1394          kallowother
1395          (nreverse keysyms)
1396          (nreverse keysupp)
1397          (nreverse keyinits)
1398          (apply #'vector (nreverse keykeys))))))
1399    (let (auxvals auxvars)
1400      (dolist (pair (%cdr auxtail))
1401        (let ((auxvar (nx-pair-name pair))
1402              (auxval (nx-pair-initform pair)))
1403          (push (if no-acode auxval (nx1-form auxval)) auxvals)
1404          (push (nx-new-var pending auxvar) auxvars)))
1405      (values
1406       (nreverse req) 
1407       opt 
1408       rest 
1409       keys
1410       (list (nreverse auxvars) (nreverse auxvals))
1411       whole))))
1412
1413(defun nx-structured-lambda-form (pending l &optional no-acode)
1414  (multiple-value-bind (req opt rest keys auxen whole)
1415                       (nx-parse-structured-lambda-list pending l no-acode t)
1416    (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
1417
1418(defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*))
1419  (let* ((*nx-form-type* t))
1420    (when (and (consp form)(eq (car form) 'the))
1421      (setq *nx-form-type* (cadr form)))
1422    (prog1
1423      (nx1-typed-form form *nx-lexical-environment*))))
1424
1425(defun nx1-typed-form (original env)
1426  (nx1-transformed-form (nx-transform original env) env))
1427
1428(defun nx1-transformed-form (form &optional (env *nx-lexical-environment*))
1429  (if (consp form)
1430    (nx1-combination form env)
1431    (let* ((symbolp (non-nil-symbol-p form))
1432           (constant-value (unless symbolp form))
1433           (constant-symbol-p nil))
1434      (if symbolp 
1435        (multiple-value-setq (constant-value constant-symbol-p) 
1436          (nx-transform-defined-constant form env)))
1437      (if (and symbolp (not constant-symbol-p))
1438        (nx1-symbol form env)
1439        (nx1-immediate (nx-unquote constant-value))))))
1440
1441
1442
1443(defun nx1-prefer-areg (form env)
1444  (nx1-form form env))
1445
1446(defun nx1-target-fixnump (form)
1447  (when (typep form 'integer)
1448       (let* ((target (backend-target-arch *target-backend*)))
1449         (and
1450          (>= form (arch::target-most-negative-fixnum target))
1451          (<= form (arch::target-most-positive-fixnum target))))))
1452
1453
1454(defun nx1-immediate (form)
1455  (if (or (eq form t) (null form))
1456    (nx1-sysnode form)
1457    (make-acode 
1458     (if (nx1-target-fixnump form) 
1459       (%nx1-operator fixnum)
1460        (%nx1-operator immediate))   ; Screw: chars
1461     form)))
1462
1463(defun nx-constant-form-p (form)
1464  (setq form (nx-untyped-form form))
1465  (if form
1466    (or (nx-null form)
1467        (nx-t form)
1468        (and (consp form)
1469             (or (eq (acode-operator form) (%nx1-operator immediate))
1470                 (eq (acode-operator form) (%nx1-operator fixnum))
1471                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
1472
1473(defun nx-natural-constant-p (form)
1474  (setq form (nx-untyped-form form))
1475  (if (consp form)
1476    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1477                        (eq (acode-operator form) (%nx1-operator immediate)))
1478                  (cadr form))))
1479      (target-word-size-case
1480       (32 (and (typep val '(unsigned-byte 32)) val))
1481       (64 (and (typep val '(unsigned-byte 64)) val))))))
1482
1483(defun nx-u32-constant-p (form)
1484  (setq form (nx-untyped-form form))
1485  (if (consp form)
1486    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1487                        (eq (acode-operator form) (%nx1-operator immediate)))
1488                  (cadr form))))
1489      (and (typep val '(unsigned-byte 32)) val))))
1490
1491(defun nx-u31-constant-p (form)
1492  (setq form (nx-untyped-form form))
1493  (if (consp form)
1494    (let* ((val (if (or (eq (acode-operator form) (%nx1-operator fixnum))
1495                        (eq (acode-operator form) (%nx1-operator immediate)))
1496                  (cadr form))))
1497      (and (typep val '(unsigned-byte 31)) val))))
1498
1499
1500;;; Reference-count vcell, fcell refs.
1501(defun nx1-note-vcell-ref (sym)
1502  (let* ((there (assq sym *nx1-vcells*))
1503         (count (expt 4 *nx-loop-nesting-level*)))
1504    (if there
1505      (%rplacd there (%i+ (%cdr there) count))
1506      (push (cons sym count) *nx1-vcells*)))
1507  sym)
1508
1509(defun nx1-note-fcell-ref (sym)
1510  (let* ((there (assq sym *nx1-fcells*))
1511         (count (expt 4 *nx-loop-nesting-level*)))
1512    (if there
1513      (%rplacd there (%i+ (%cdr there) count))
1514      (push (cons sym count) *nx1-fcells*))
1515    sym))
1516
1517; Note that "simple lexical refs" may not be; that's the whole problem ...
1518(defun nx1-symbol (form &optional (env *nx-lexical-environment*))
1519  (let* ((type (nx-declared-type form))
1520         (form
1521          (multiple-value-bind (info inherited-p more)
1522                               (nx-lex-info form)
1523            (if (and info (neq info :special))
1524              (if (eq info :symbol-macro)
1525                (progn
1526                  (nx-set-var-bits more (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits more)))
1527                  (if (eq type t)
1528                    (nx1-form inherited-p)
1529                    (nx1-form `(the ,(prog1 type (setq type t)) ,inherited-p))))
1530                (progn
1531                  (when (not inherited-p)
1532                    (nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1) (nx-var-bits info)))
1533                    (nx-adjust-ref-count info))
1534                  (make-acode (%nx1-operator lexical-reference) info)))
1535              (make-acode
1536               (if (nx1-check-special-ref form info)
1537                   (progn
1538                     (nx-record-xref-info :references form)
1539                     (if (nx-global-p form env)
1540                         (%nx1-operator global-ref)
1541                         (if (and (not (nx-force-boundp-checks form env))
1542                                  (or (nx-proclaimed-parameter-p form)
1543                                  (assq form *nx-compile-time-types*)
1544                                  (assq form *nx-proclaimed-types*)
1545                                  (nx-open-code-in-line env)))
1546                             (%nx1-operator bound-special-ref)
1547                             (%nx1-operator special-ref))))
1548                   (%nx1-operator free-reference))
1549               (nx1-note-vcell-ref form))))))
1550    (if (eq type t)
1551        form
1552      (make-acode (%nx1-operator typed-form) type form))))
1553
1554(defun nx1-check-special-ref (form auxinfo)
1555  (or (eq auxinfo :special) 
1556      (nx-proclaimed-special-p form)
1557      (let ((defenv (definition-environment *nx-lexical-environment*)))
1558        (unless (and defenv (eq (car (defenv.type defenv)) :execute) (boundp form))
1559          (nx1-whine :special form))
1560        nil)))
1561
1562
1563
1564(defun nx1-whine (about &rest forms)
1565    (push (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
1566                          :function-name (list *nx-cur-func-name*)
1567                          :warning-type about
1568                          :args (or forms (list nil)))
1569          *nx-warnings*)
1570  nil)
1571
1572(defun nx1-type-intersect (form type1 type2 &optional env)
1573  (declare (ignore env)) ; use it when deftype records info in env.  Fix this then ...
1574  (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1)))
1575         (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2)))
1576         (intersection (type-intersection ctype1 ctype2)))
1577    (if (eq intersection *empty-type*)
1578      (let ((type1 (if (typep type1 'ctype)
1579                     (type-specifier type1)
1580                     type1))
1581            (type2 (if (typep type2 'ctype)
1582                     (type-specifier type2)
1583                     type2)))
1584        (nx1-whine :type-conflict form type1 type2)))
1585    (type-specifier intersection)))
1586                 
1587
1588
1589(defun nx-declared-notinline-p (sym env)
1590  (setq sym (maybe-setf-function-name sym))
1591  (loop
1592    (when (listp env)
1593      (return (and (symbolp sym)
1594                   (proclaimed-notinline-p sym))))
1595    (dolist (decl (lexenv.fdecls env))
1596      (when (and (eq (car decl) sym)
1597                 (eq (cadr decl) 'inline))
1598         (return-from nx-declared-notinline-p (eq (cddr decl) 'notinline))))
1599    (setq env (lexenv.parent-env env))))
1600
1601
1602
1603(defun nx1-combination (form env)
1604  (destructuring-bind (sym &rest args)
1605                      form
1606    (if (symbolp sym)
1607      (let* ((*nx-sfname* sym) special)
1608        (if (and (setq special (gethash sym *nx1-alphatizers*))
1609                 ;(not (nx-lexical-finfo sym env))
1610                 (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
1611          (funcall special form env) ; pass environment arg ...
1612          (progn           
1613            (nx1-typed-call sym args))))
1614      (if (lambda-expression-p sym)
1615        (nx1-lambda-bind (%cadr sym) args (%cddr sym))
1616      (nx-error "~S is not a symbol or lambda expression in the form ~S ." sym form)))))
1617
1618(defun nx1-treat-as-call (args)
1619  (nx1-typed-call (car args) (%cdr args)))
1620
1621(defun nx1-typed-call (sym args)
1622  (let ((type (nx1-call-result-type sym args))
1623        (form (nx1-call sym args)))
1624    (if (eq type t)
1625      form
1626      (list (%nx1-operator typed-form) type form))))
1627
1628; Wimpy.
1629(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p)
1630  (let* ((env *nx-lexical-environment*)
1631         (global-def nil)
1632         (lexenv-def nil)
1633         (defenv-def nil)
1634         (somedef nil))
1635    (when (and sym 
1636               (symbolp sym)
1637               (not (find-ftype-decl sym env))
1638               (not (setq lexenv-def (nth-value 1 (nx-lexical-finfo sym))))
1639               (null (setq defenv-def (retrieve-environment-function-info sym env)))
1640               (neq sym *nx-global-function-name*)
1641               (not (functionp (setq global-def (fboundp sym)))))
1642      (nx1-whine :undefined-function sym))
1643    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
1644      (multiple-value-bind (deftype required max minargs maxargs)
1645                           (nx1-check-call-args somedef args spread-p)
1646        (when deftype
1647          (nx1-whine (if (eq deftype :lexical-mismatch) :environment-mismatch deftype)
1648                     sym required max minargs maxargs))))
1649    *nx-form-type*))
1650
1651(defun find-ftype-decl (sym env)
1652  (setq sym (maybe-setf-function-name sym))
1653  (loop 
1654    (when (listp env)
1655      (return (and (symbolp sym)
1656                   (proclaimed-ftype sym))))
1657    (dolist (fdecl (lexenv.fdecls env))
1658      (declare (list fdecl))
1659      (when (and (eq (car fdecl) sym)
1660                 (eq (car (the list (cdr fdecl))) 'ftype))
1661        (return-from find-ftype-decl (cdr (the list (cdr fdecl))))))
1662    (setq env (lexenv.parent-env env))))
1663
1664(defun innermost-lfun-bits-keyvect (def)
1665 (declare (notinline innermost-lfun-bits-keyvect))
1666  (let* ((gf-p (standard-generic-function-p def)))
1667    (unless gf-p
1668      (let ((inner-def (closure-function (find-unencapsulated-definition def))))
1669        (values (lfun-bits inner-def)(lfun-keyvect inner-def))))))
1670
1671
1672(defun nx1-check-call-args (def arglist spread-p)
1673  (let* ((deftype (if (functionp def) 
1674                    :global-mismatch
1675                    (if (istruct-typep def 'afunc)
1676                      :lexical-mismatch
1677                      :environment-mismatch))))
1678    (multiple-value-bind (bits keyvect)
1679                         (case deftype
1680                           (:global-mismatch (innermost-lfun-bits-keyvect def))
1681                           (:environment-mismatch (values (caadr def) (cdadr def)))
1682                           (t (let* ((lambda-form (afunc-lambdaform def)))
1683                                (if (lambda-expression-p lambda-form)
1684                                  (encode-lambda-list (cadr lambda-form))))))
1685      (when bits
1686        (unless (typep bits 'fixnum) (bug "Bad bits!"))
1687        (let* ((nargs (length arglist))
1688               (minargs (if spread-p (1- nargs) nargs))
1689               (maxargs (if spread-p nil nargs))
1690               (required (ldb $lfbits-numreq bits))
1691               (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
1692                      nil
1693                      (+ required (ldb $lfbits-numopt bits)))))
1694          ;; If the (apparent) number of args in the call doesn't match the definition, complain.
1695          ;; If "spread-p" is true, we can only be sure of the case when more than the required number of
1696          ;; args have been supplied.
1697          (if (or (and (not spread-p) (< minargs required))
1698                  (and max (or (> minargs max)) (if maxargs (> maxargs max)))
1699                  (nx1-find-bogus-keywords arglist spread-p bits keyvect))
1700            (values deftype required max minargs maxargs)))))))
1701
1702(defun nx1-find-bogus-keywords (args spread-p bits keyvect)
1703  (declare (fixnum bits))
1704  (when (logbitp $lfbits-aok-bit bits)
1705    (setq keyvect nil))                 ; only check for even length tail
1706  (when (and (logbitp $lfbits-keys-bit bits) 
1707             (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
1708    (do* ((key-args (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args) (cddr key-args)))
1709         ((null key-args))
1710      (if (null (cdr key-args))
1711        (return t)
1712        (when keyvect
1713          (let* ((keyword (%car key-args)))
1714            (unless (constantp keyword)
1715              (return nil))
1716            (unless (eq keyword :allow-other-keys)
1717              (unless (position (nx-unquote keyword) keyvect)
1718                (return t)))))))))
1719
1720;  we can save some space by going through subprims to call
1721; "builtin" functions for us.
1722(defun nx1-builtin-function-offset (name)
1723   (arch::builtin-function-name-offset name))
1724
1725(defun nx1-call-form (global-name afunc arglist spread-p)
1726  (if afunc
1727    (make-acode (%nx1-operator lexical-function-call) afunc (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*))) spread-p)
1728    (let* ((builtin (unless spread-p (nx1-builtin-function-offset global-name))))
1729      (if builtin
1730        (make-acode (%nx1-operator builtin-call) 
1731                    (make-acode (%nx1-operator fixnum) builtin)
1732                    (nx1-arglist arglist))
1733        (make-acode (%nx1-operator call)
1734                     (if (symbolp global-name)
1735                       (nx1-immediate (nx1-note-fcell-ref global-name))
1736                       global-name)
1737                     (nx1-arglist arglist (if spread-p 1 (backend-num-arg-regs *target-backend*)))
1738                     spread-p)))))
1739 
1740; If "sym" is an expression (not a symbol which names a function), the caller has already
1741; alphatized it.
1742(defun nx1-call (sym args &optional spread-p global-only)
1743  (nx1-verify-length args 0 nil)
1744  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
1745    (if (nx-self-call-p sym global-only)
1746      ; Should check for downward functions here as well.
1747      (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p)
1748      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
1749        (or (nx1-expand-inline-call lambda-form containing-env token args spread-p)
1750            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
1751              (when (eq 'macro (car info))
1752                (nx-error "Can't call macro function ~s" sym))
1753              (nx-record-xref-info :direct-calls sym)
1754              (if (and afunc (%ilogbitp $fbitruntimedef (afunc-bits afunc)))
1755                (let ((sym (var-name (afunc-lfun afunc))))
1756                  (nx1-form 
1757                   (if spread-p
1758                     `(,(if (eql spread-p 0) 'applyv 'apply) ,sym ,args)
1759                     `(funcall ,sym ,@args))))
1760                (let* ((val (nx1-call-form sym afunc args spread-p)))
1761                    (when afunc
1762                      (let ((callers (afunc-callers afunc))
1763                            (self *nx-current-function*))
1764                        (unless (or (eq self afunc) (memq self callers))
1765                          (setf (afunc-callers afunc) (cons self callers)))))
1766                    (if (and (null afunc) (memq sym *nx-never-tail-call*))
1767                      (make-acode (%nx1-operator values) (list val))
1768                      val)))))))))
1769
1770(defun nx1-expand-inline-call (lambda-form env token args spread-p)
1771  (if (and (or (null spread-p) (eq (length args) 1)))
1772    (if (and token (not (memq token *nx-inline-expansions*)))
1773      (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
1774             (lambda-list (cadr lambda-form))
1775             (body (cddr lambda-form)))
1776        (if spread-p
1777          (nx1-destructure lambda-list (car args) nil nil body env)
1778          (nx1-lambda-bind lambda-list args body env))))))
1779             
1780; note that regforms are reversed: arg_z is always in the car
1781(defun nx1-arglist (args &optional (nregargs (backend-num-arg-regs *target-backend*)))
1782  (declare (fixnum nregargs))
1783  (let* ((stkforms nil)
1784         (regforms nil)
1785         (nstkargs (%i- (length args) nregargs)))
1786    (declare (fixnum nstkargs))
1787      (list
1788       (dotimes (i nstkargs (nreverse stkforms))
1789         (declare (fixnum i))
1790         (push (nx1-form (%car args)) stkforms)
1791         (setq args (%cdr args)))
1792       (dolist (arg args regforms)
1793         (push (nx1-form arg) regforms)))))
1794
1795(defun nx1-formlist (args)
1796  (let* ((a nil))
1797    (dolist (arg args)
1798      (push (nx1-form arg) a))
1799    (nreverse a)))
1800
1801(defun nx1-verify-length (forms min max &aux (len (list-length forms)))
1802 (if (or (null len)
1803         (%i> min len)
1804         (and max (%i> len max)))
1805     (nx-error "Wrong number of args in form ~S." (cons *nx-sfname* forms))
1806     len))
1807
1808(defun nx-unquote (form)
1809  (if (nx-quoted-form-p form)
1810    (%cadr form)
1811    form))
1812
1813(defun nx-quoted-form-p (form &aux (f form))
1814 (and (consp form)
1815      (eq (pop form) 'quote)
1816      (or
1817       (and (consp form)
1818            (not (%cdr form)))
1819       (nx-error "Illegally quoted form ~S." f))))
1820
1821; Returns two values: expansion & win
1822; win is true if expansion is not EQ to form.
1823; This is a bootstrapping version.
1824; The real one is in "ccl:compiler;optimizers.lisp".
1825(unless (fboundp 'maybe-optimize-slot-accessor-form)
1826
1827(defun maybe-optimize-slot-accessor-form (form environment)
1828  (declare (ignore environment))
1829  (values form nil))
1830
1831)
1832
1833(defun nx-transform (form &optional (environment *nx-lexical-environment*))
1834  (let* (sym transforms lexdefs changed enabled macro-function compiler-macro)
1835    (tagbody
1836       (go START)
1837     LOOP
1838       (setq changed t)
1839       (when (and (consp form) 
1840                  (or (eq (%car form) 'the)
1841                      (and sym (eq (%car form) sym))))
1842         (go DONE))
1843     START
1844       (when (non-nil-symbol-p form)
1845         (multiple-value-bind (newform win) (nx-transform-symbol form environment)
1846           (unless win (go DONE))
1847           (setq form newform changed (or changed win))
1848           (go LOOP)))
1849       (when (atom form) (go DONE))
1850       (unless (symbolp (setq sym (%car form)))
1851         (go DONE))
1852       (when (eq sym 'the)
1853         (destructuring-bind (typespec thing) (cdr form)
1854           (multiple-value-bind (newform win) (nx-transform thing environment)
1855             (when win
1856               (setq changed t)
1857               (if (and (self-evaluating-p newform)
1858                        (typep newform typespec))
1859                 (setq form newform)
1860                 (setq form `(the ,typespec ,newform)))
1861               (go DONE)))))
1862       (when (nx-quoted-form-p form)
1863         (when (self-evaluating-p (%cadr form))
1864           (setq form (%cadr form)))
1865         (go DONE))
1866       (when (setq lexdefs (nx-lexical-finfo sym environment))
1867         (if (eq 'function (%car lexdefs))
1868           (go DONE)))
1869       (setq transforms (setq compiler-macro (compiler-macro-function sym environment))
1870             macro-function (macro-function sym environment)
1871             enabled (nx-allow-transforms environment))
1872       (unless macro-function
1873         (let* ((win nil))
1874           (when (and enabled (functionp (fboundp sym)))
1875             (multiple-value-setq (form win) (nx-transform-arglist form environment))
1876             (if win (setq changed t)))))
1877       (when (and enabled
1878                  (not (nx-declared-notinline-p sym environment)))
1879         (multiple-value-bind (value folded) (nx-constant-fold form environment)
1880           (when folded (setq form value changed t)  (unless (and (consp form) (eq (car form) sym)) (go START))))
1881         (when compiler-macro
1882           (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
1883             (when win
1884               (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym)))
1885                 (setq sym nil))
1886               (setq form newform)
1887               (go LOOP))))
1888         (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment)
1889           (when win
1890             (setq sym nil)
1891             (setq form newform)
1892             (go START)))
1893         (unless macro-function
1894           (when (setq transforms (or (environment-structref-info sym environment)
1895                                      (and #-bccl (boundp '%structure-refs%)
1896                                           (gethash sym %structure-refs%))))
1897             (setq form (defstruct-ref-transform transforms (%cdr form)) changed T)
1898             (go START))
1899           (when (setq transforms (assq sym *nx-synonyms*))
1900             (setq form (cons (%cdr transforms) (setq sym (%cdr form))))
1901             (go LOOP))))
1902       (when (and macro-function
1903                  (or lexdefs
1904                      (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment))))))
1905         (nx-record-xref-info :macro-calls (function-name macro-function))
1906         (setq form (macroexpand-1 form environment) changed t)
1907         (go START))
1908     DONE)
1909    (values form changed)))
1910
1911; Transform all of the arguments to the function call form.
1912; If any of them won, return a new call form (with the same operator as the original), else return the original
1913; call form unchanged.
1914
1915(defun nx-transform-arglist (callform env)
1916    (let* ((any-wins nil)
1917           (transformed-call (cons (car callform) nil))
1918           (ptr transformed-call)
1919           (win nil))
1920      (declare (type cons ptr))
1921      (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
1922        (rplacd ptr (setq ptr (cons (multiple-value-setq (form win) (nx-transform form env)) nil)))
1923        (if win (setq any-wins t)))))
1924
1925;This is needed by (at least) SETF.
1926(defun nxenv-local-function-p (name macro-env)
1927  (multiple-value-bind (type local-p) (function-information name macro-env)
1928    (and local-p (eq :function type))))
1929
1930           
1931; This guy has to return multiple values.
1932; The arguments have already been transformed; if they're all constant (or quoted), try
1933; to evaluate the expression at compile-time.
1934(defun nx-constant-fold (original-call &optional (environment *nx-lexical-environment*) &aux 
1935                                       (fn (car original-call)) form mv foldable foldfn)
1936  (flet ((quotify (x) (if (self-evaluating-p x) x (list 'quote x))))
1937    (if (and (nx-allow-transforms environment)
1938             (let* ((bits (if (symbolp fn) (%symbol-bits fn) 0)))
1939               (declare (fixnum bits))
1940               (if (setq foldable (logbitp $sym_fbit_constant_fold bits))
1941                 (if (logbitp $sym_fbit_fold_subforms bits)
1942                   (setq foldfn 'fold-constant-subforms))
1943                 (setq foldable (assq fn *nx-can-constant-fold*)
1944                       foldfn (cdr foldable)))
1945               foldable))
1946      (if foldfn
1947        (funcall foldfn original-call environment)
1948        (progn
1949            (let ((args nil))
1950              (dolist (arg (cdr original-call) (setq args (nreverse args)))
1951                (if (quoted-form-p arg)
1952                  (setq arg (%cadr arg))
1953                  (unless (self-evaluating-p arg) (return-from nx-constant-fold (values original-call nil))))
1954                (push arg args))
1955              (setq form (multiple-value-list 
1956                          (handler-case (apply fn args)
1957                            (error (condition)
1958                                   (warn "Error: \"~A\" ~&signalled during compile-time evaluation of ~S ."
1959                                         condition original-call)
1960                                   (return-from nx-constant-fold
1961                                     (values `(locally (declare (notinline ,fn))
1962                                                ,original-call)
1963                                             t)))))))
1964          (if form
1965            (if (null (%cdr form))
1966              (setq form (%car form))
1967              (setq mv (setq form (cons 'values (mapcar #'quotify form))))))
1968          (values (if mv form (quotify form)) T)))
1969      (values original-call nil))))
1970
1971(defun nx-transform-symbol (sym &optional (env *nx-lexical-environment*))
1972; Gak.  Can't call NX-LEX-INFO without establishing *nx-lexical-environment*.
1973; NX-LEX-INFO should take env arg!.
1974  (let* ((*nx-lexical-environment* env))
1975    (multiple-value-bind (expansion win) (macroexpand-1 sym env)
1976      (if win
1977        (let ((type (nx-declared-type sym))
1978              (var (nth-value 2 (nx-lex-info sym))))
1979          (unless (eq t type) (setq expansion `(the ,type ,expansion)))
1980          (if var (nx-set-var-bits var (%ilogior (%ilsl $vbitreffed 1) (nx-var-bits var)))))
1981        (progn
1982          (multiple-value-setq (expansion win)
1983            (nx-transform-defined-constant sym env))
1984          (if win (setq win (neq sym expansion)))))
1985      (values expansion win))))
1986
1987; if sym has a substitutable constant value in env (or globally), return
1988; (values <value> t), else (values nil nil)
1989(defun nx-transform-defined-constant (sym env)
1990  (let* ((defenv (definition-environment env))
1991         (val (if defenv (assq sym (defenv.constants defenv))))
1992         (constant-value-p val))
1993    (if val
1994      (setq val (%cdr val))
1995      (if (constant-symbol-p sym)
1996        (setq constant-value-p t val (%sym-global-value sym))))
1997    (if (and (neq val (%unbound-marker-8))
1998             constant-value-p 
1999             (nx-substititute-constant-value sym val env))
2000      (values (if (self-evaluating-p val) val (list 'quote val)) t)
2001      (values nil nil))))
2002
2003
2004(defun nx-var-bits (var)
2005  (do* ((var var bits)
2006        (bits (var-bits var) (var-bits var)))
2007       ((fixnump bits) bits)))
2008
2009(defun nx-set-var-bits (var newbits)
2010  (do* ((var var bits)
2011        (bits (var-bits var) (var-bits var)))
2012       ((fixnump bits) (setf (var-bits var) newbits))))
2013
2014(defun nx-adjust-ref-count (var)
2015  (let* ((bits (nx-var-bits var))
2016         (temp-p (%ilogbitp $vbittemporary bits))
2017         (by (if temp-p 1 (expt  4 *nx-loop-nesting-level*)))
2018         (new (%imin (%i+ (%ilogand2 $vrefmask bits) by) 255)))
2019    (nx-set-var-bits var (%ilogior (%ilogand (%ilognot $vrefmask) bits) new))
2020    new))
2021
2022
2023(defun nx-form-type (form &optional (env *nx-lexical-environment*))
2024  (if (self-evaluating-p form)
2025    (type-of form)
2026    (if (and (consp form)               ; Kinda bogus now, but require-type
2027             (eq (%car form) 'require-type) ; should be special some day
2028             (quoted-form-p (caddr form)))
2029      (%cadr (%caddr form))
2030      (if (nx-trust-declarations env)
2031        (if (symbolp form)
2032          (nx-declared-type form env)
2033          (if (consp form)
2034            (if (eq (%car form) 'the) 
2035              (cadr form)
2036              (if (eq (%car form) 'setq)
2037                (nx-declared-type (cadr form) env)
2038                (let* ((op (gethash (%car form) *nx1-operators*)))
2039                  (or (and op (cdr (assq op *nx-operator-result-types*)))       ;
2040                      (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
2041                      (and (memq (car form) *numeric-ops*)
2042                           (grovel-numeric-form form env))
2043                      (and (memq (car form) *logical-ops*)
2044                           (grovel-logical-form form env))
2045                      t))))
2046            t))
2047        t))))
2048
2049(defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
2050
2051(defparameter *logical-ops* '(logxor-2 logior-2 logand-2  lognot logxor))
2052
2053(defun numeric-type-p (type &optional not-complex)
2054  (or (memq type '(fixnum integer double-float single-float float))
2055      (let ((ctype (specifier-type type)))
2056        (and (numeric-ctype-p ctype)
2057             (or (not not-complex)
2058                 (neq (numeric-ctype-complexp ctype) :complex))))))
2059
2060
2061; doesn't do ranges so good
2062; this is an adhoc piece of junk that deals with the following cases
2063; 1) if numeric op of known fixnums and result is known fixnum, just do it for any number args
2064; 2) if numeric op and any arg is known double-float, result is double-float
2065;      unless any arg is complex or not known numeric
2066; dealing specially with / - only know result if something known double-float
2067; then there's e.g. progn whose last form is known type......
2068
2069(defun grovel-numeric-form (form env)
2070  (when (nx-trust-declarations env)
2071    (let ((op (car form))
2072          type)
2073      (dolist (arg (cdr form))
2074        (let ((it (nx-form-type arg env)))
2075          (if (or (eq it 'complex)(not (numeric-type-p it t)))
2076            (return (setq type nil))
2077            (if (or (eq it 'double-float)(eq type 'double-float))
2078              (setq type 'double-float)
2079              (if type
2080                (if (subtypep it type)
2081                  (setq type type)
2082                  (if (subtypep type it)
2083                    (setq type it)
2084                    (return (setq type nil))))
2085                (setq type it))))))
2086      (when type 
2087        (if (memq op '(/ /-2))
2088          (if (eq type 'double-float) type nil)
2089          ;  + of fixnum and fixnum not always fixnum
2090          (if (subtypep type 'fixnum)
2091            (if (and (memq op '(+ - +-2 --2))
2092                     (subtypep type '(signed-byte 28))(< (length form) 5)) ; or 29? - but form not always binary
2093              'fixnum
2094              (if (eq *nx-form-type* 'fixnum) 'fixnum 'integer))
2095            (if (memq type '(integer double-float)) type)))))))
2096
2097; now e.g. logxor of 3 known fixnums is inline as is (logior a (logxor b c))
2098; and (the fixnum (+ a (logxor b c)))
2099
2100(defun grovel-logical-form (form env)
2101  (when (nx-trust-declarations env)
2102    (let (;(op (car form))
2103          type)
2104      (dolist (arg (cdr form))
2105        (let ((it (nx-form-type arg env)))         
2106          (if (not (subtypep it 'fixnum))
2107            (return (setq type nil))
2108            (setq type 'fixnum))))
2109      type)))
2110
2111(defun nx-form-typep (arg type &optional (env *nx-lexical-environment*))
2112  (setq type (type-expand type))
2113  (if (constantp arg)
2114    (typep arg type)
2115    (subtypep (nx-form-type arg env) type)))
2116
2117
2118(defun nx-binary-fixnum-op-p (form1 form2 env &optional ignore-result-type)
2119  (setq form1 (nx-transform form1 env)
2120        form2 (nx-transform form2 env))
2121  (and
2122   (target-word-size-case
2123    (32 (nx-form-typep form1 '(signed-byte 30) env))
2124    (64 (nx-form-typep form1 '(signed-byte 61) env)))
2125   (target-word-size-case
2126    (32 (nx-form-typep form2 '(signed-byte 30) env))
2127    (64 (nx-form-typep form2 '(signed-byte 61) env)))
2128   (or ignore-result-type
2129        (and (nx-trust-declarations env)
2130                (target-word-size-case
2131                 (32 (subtypep *nx-form-type* '(signed-byte 30)))
2132                 (64 (subtypep *nx-form-type* '(signed-byte 61))))))))
2133
2134
2135(defun nx-binary-natural-op-p (form1 form2 env &optional (ignore-result-type t))
2136  (and
2137   (target-word-size-case
2138    (32
2139     (and (nx-form-typep form1 '(unsigned-byte 32)  env)
2140          (nx-form-typep form2 '(unsigned-byte 32)  env)))
2141    (64
2142     (and (nx-form-typep form1 '(unsigned-byte 64)  env)
2143          (nx-form-typep form2 '(unsigned-byte 64)  env))))
2144   (or ignore-result-type
2145       (and (nx-trust-declarations env)
2146            (target-word-size-case
2147             (32 (subtypep *nx-form-type* '(unsigned-byte 32)))
2148             (64 (subtypep *nx-form-type* '(unsigned-byte 64))))))))
2149
2150   
2151
2152
2153(defun nx-binary-boole-op (whole env arg-1 arg-2 fixop intop naturalop)
2154  (let* ((use-fixop (nx-binary-fixnum-op-p arg-1 arg-2 env t))
2155         (use-naturalop (nx-binary-natural-op-p arg-1 arg-2 env)))
2156    (if (or use-fixop use-naturalop intop)
2157      (make-acode (if use-fixop fixop (if use-naturalop naturalop intop))
2158                  (nx1-form arg-1)
2159                  (nx1-form arg-2))
2160      (nx1-treat-as-call whole))))
2161
2162(defun nx-global-p (sym &optional (env *nx-lexical-environment*))
2163  (or 
2164   (logbitp $sym_vbit_global (the fixnum (%symbol-bits sym)))
2165   (let* ((defenv (definition-environment env)))
2166     (if defenv 
2167       (eq :global (%cdr (assq sym (defenv.specials defenv))))))))
2168 
2169(defun nx-need-var (sym &optional (check-bindable t))
2170  (if (and (nx-need-sym sym)
2171           (not (constantp sym))
2172           (let* ((defenv (definition-environment *nx-lexical-environment*)))
2173             (or (null defenv)
2174                 (not (assq sym (defenv.constants defenv)))))) ; check compile-time-constants, too
2175    (if (and check-bindable (nx-global-p sym))
2176      (nx-error "~S is global and can not be bound . " sym)
2177      sym)
2178    (nx-error "Can't bind or assign to constant ~S." sym)))
2179
2180(defun nx-need-sym (sym)
2181  (if (symbolp sym)
2182    sym
2183    (nx-error "~S is not a symbol." sym)))
2184
2185(defun nx-need-function-name (name)
2186  (multiple-value-bind (valid nm) (valid-function-name-p name)
2187    (if valid nm (nx-error "Invalid function name ~S" name))))
2188
2189(defun nx-pair-name (form)
2190  (nx-need-sym (if (consp form) (%car form) form)))
2191
2192(defun nx-pair-initform (form)
2193  (if (atom form)
2194    nil
2195    (if (and (listp (%cdr form)) (null (%cddr form)))
2196      (%cadr form)
2197      (nx-error "Bad initialization form: ~S." form))))
2198
2199; some callers might assume that this guy errors out if it can't conjure up
2200; a fixnum.  I certainly did ...
2201(defun nx-get-fixnum (form &aux (trans (nx-transform form *nx-lexical-environment*)))
2202 (if (fixnump trans)
2203  trans
2204  form))
2205 
2206(defun nx1-func-name (gizmo)
2207  (and (consp gizmo)
2208       (or (eq (%car gizmo) 'function) (eq (%car gizmo) 'quote))
2209       (consp (%cdr gizmo))
2210       (null (%cddr gizmo))
2211       (nth-value 1 (valid-function-name-p (%cadr gizmo)))))
2212
2213; distinguish between program errors & incidental ones.
2214(defun nx-error (format-string &rest args)
2215  (error (make-condition 'compile-time-program-error 
2216                :context (nx-error-context)
2217                :format-control format-string
2218                :format-arguments args)))
2219
2220(defun nx-compile-time-error (format-string &rest args)
2221  (error (make-condition 'compile-time-program-error 
2222                :context (nx-error-context)
2223                :format-control format-string
2224                :format-arguments args)))
2225
2226; Should return information about file being compiled, nested functions, etc. ...
2227(defun nx-error-context ()
2228  (or *nx-cur-func-name* "an anonymous function"))
2229
Note: See TracBrowser for help on using the repository browser.