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

Last change on this file since 15314 was 15314, checked in by gb, 8 years ago

Warn (via full warning) on duplicate bindings in SYMBOL-MACROLET,
MACROLET, FLET, LABELS (fixes ticket:927.)

If a DECLARE expression is encountered when a form is expected,
make the error message more verbose (and mention macroexpansion
as a possible cause of the problem.) Fixes ticket:926.

Warn (via a full warning) if a local function shadows a global
CL function name. Fixes ticket:923.

If STYLE-WARNINGs are incidentally signaled during (e.g.)
macroexpansion and are handled and postprocessed by the compiler,
ensure that the warning actually generated will be a STYLE-WARNING.

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