source: branches/working-0711/ccl/compiler/nx0.lisp @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

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