UPGRADED-ARRAY-ELEMENT-TYPE: more thoroughly signal errors on unknown types.

[sbcl.git] / src / compiler / ir1tran.lisp

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 8f80aef..10e2ddd 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -14,15 +14,57 @@
 
 (declaim (special *compiler-error-bailout*))
 
 
 (declaim (special *compiler-error-bailout*))
 

+;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the
+;;; form number to associate with a source path. This should be bound
+;;; to an initial value of 0 before the processing of each truly
+;;; top level form.
+(declaim (type index *current-form-number*))
+(defvar *current-form-number*)
+

 ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path
 ;;; taken through the source to reach the form. This provides a way to
 ;;; keep track of the location of original source forms, even when
 ;;; macroexpansions and other arbitary permutations of the code
 ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on
 ;;; the original source.
 ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path
 ;;; taken through the source to reach the form. This provides a way to
 ;;; keep track of the location of original source forms, even when
 ;;; macroexpansions and other arbitary permutations of the code
 ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on
 ;;; the original source.

+;;;
+;;; It is fairly useless to store symbols, characters, or fixnums in
+;;; this table, as 42 is EQ to 42 no matter where in the source it
+;;; appears. GET-SOURCE-PATH and NOTE-SOURCE-PATH functions should be
+;;; always used to access this table.

 (declaim (hash-table *source-paths*))
 (defvar *source-paths*)
 
 (declaim (hash-table *source-paths*))
 (defvar *source-paths*)
 

+(declaim (inline source-form-has-path-p))
+(defun source-form-has-path-p (form)
+  (not (typep form '(or symbol fixnum character))))
+
+(defun get-source-path (form)
+  (when (source-form-has-path-p form)
+    (gethash form *source-paths*)))
+
+(defun ensure-source-path (form)
+  (or (get-source-path form)
+      (cons (simplify-source-path-form form)
+            *current-path*)))
+
+(defun simplify-source-path-form (form)
+  (if (consp form)
+      (let ((op (car form)))
+        ;; In the compiler functions can be directly represented
+        ;; by leaves. Having leaves in the source path is pretty
+        ;; hard on the poor user, however, so replace with the
+        ;; source-name when possible.
+        (if (and (leaf-p op) (leaf-has-source-name-p op))
+            (cons (leaf-source-name op) (cdr form))
+            form))
+      form))
+
+(defun note-source-path (form &rest arguments)
+  (when (source-form-has-path-p form)
+    (setf (gethash form *source-paths*)
+          (apply #'list* 'original-source-start *current-form-number* arguments))))
+

 ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link
 ;;; blocks into as we generate them. This just serves to glue the
 ;;; emitted blocks together until local call analysis and flow graph
 ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link
 ;;; blocks into as we generate them. This just serves to glue the
 ;;; emitted blocks together until local call analysis and flow graph

@@ -62,6 +104,18 @@
         (eq (defined-fun-inlinep fun) :notinline)
         (eq (info :function :inlinep name) :notinline))))
 
         (eq (defined-fun-inlinep fun) :notinline)
         (eq (info :function :inlinep name) :notinline))))
 

+;; This will get redefined in PCL boot.
+(declaim (notinline maybe-update-info-for-gf))
+(defun maybe-update-info-for-gf (name)
+  (declare (ignore name))
+  nil)
+
+(defun maybe-defined-here (name where)
+  (if (and (eq :defined where)
+           (member name *fun-names-in-this-file* :test #'equal))
+      :defined-here
+      where))
+

 ;;; Return a GLOBAL-VAR structure usable for referencing the global
 ;;; function NAME.
 (defun find-global-fun (name latep)
 ;;; Return a GLOBAL-VAR structure usable for referencing the global
 ;;; function NAME.
 (defun find-global-fun (name latep)

@@ -82,61 +136,69 @@
                ;; complain about undefined functions.
                (not latep))
       (note-undefined-reference name :function))
                ;; complain about undefined functions.
                (not latep))
       (note-undefined-reference name :function))

-    (make-global-var
-     :kind :global-function
-     :%source-name name
-     :type (if (and (not latep)
-                    (or *derive-function-types*
-                        (eq where :declared)
-                        (and (member name *fun-names-in-this-file*
-                                     :test #'equal)
-                             (not (fun-lexically-notinline-p name)))))
-               (info :function :type name)
-               (specifier-type 'function))
-     :where-from where)))
-
-;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
+    (let ((ftype (info :function :type name))
+          (notinline (fun-lexically-notinline-p name)))
+      (make-global-var
+       :kind :global-function
+       :%source-name name
+       :type (if (or (eq where :declared)
+                     (and (not latep)
+                          (not notinline)
+                          *derive-function-types*))
+                 ftype
+                 (specifier-type 'function))
+       :defined-type (if (and (not latep) (not notinline))
+                         (or (maybe-update-info-for-gf name) ftype)
+                         (specifier-type 'function))
+       :where-from (if notinline
+                       where
+                       (maybe-defined-here name where))))))
+
+;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid?
+;;; Drop 'em.

 ;;;
 ;;;

-;;; In CMU CL, the answer was implicitly always true, so this
-;;; predicate didn't exist.
-;;;
-;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
-;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
-;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
-;;; "dead") component. When this IR1 stuff was reused in a new
-;;; component, under further obscure circumstances it could be used by
+;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS*
+;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object
+;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled
+;;; (aka "dead") component. When this IR1 stuff was reused in a new component,
+;;; under further obscure circumstances it could be used by

 ;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for
 ;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for

-;;; *CURRENT-COMPONENT*. At that point things got all confused, since
-;;; IR1 conversion was sending code to a component which had already
-;;; been compiled and would never be compiled again.
-(defun invalid-free-fun-p (free-fun)
+;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1
+;;; conversion was sending code to a component which had already been compiled
+;;; and would never be compiled again.
+;;;
+;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original
+;;; BUGS entry also makes it seem like this might not be an issue at all on
+;;; target.
+(defun clear-invalid-functionals (free-fun)

   ;; There might be other reasons that *FREE-FUN* entries could
   ;; become invalid, but the only one we've been bitten by so far
   ;; (sbcl-0.pre7.118) is this one:
   ;; There might be other reasons that *FREE-FUN* entries could
   ;; become invalid, but the only one we've been bitten by so far
   ;; (sbcl-0.pre7.118) is this one:

-  (and (defined-fun-p free-fun)
-       (let ((functional (defined-fun-functional free-fun)))
-         (or (and functional
-                  (eql (functional-kind functional) :deleted))
-             (and (lambda-p functional)
-                  (or
-                   ;; (The main reason for this first test is to bail
-                   ;; out early in cases where the LAMBDA-COMPONENT
-                   ;; call in the second test would fail because links
-                   ;; it needs are uninitialized or invalid.)
-                   ;;
-                   ;; If the BIND node for this LAMBDA is null, then
-                   ;; according to the slot comments, the LAMBDA has
-                   ;; been deleted or its call has been deleted. In
-                   ;; that case, it seems rather questionable to reuse
-                   ;; it, and certainly it shouldn't be necessary to
-                   ;; reuse it, so we cheerfully declare it invalid.
-                   (null (lambda-bind functional))
-                   ;; If this IR1 stuff belongs to a dead component,
-                   ;; then we can't reuse it without getting into
-                   ;; bizarre confusion.
-                   (eql (component-info (lambda-component functional))
-                        :dead)))))))
+  (when (defined-fun-p free-fun)
+    (setf (defined-fun-functionals free-fun)
+          (delete-if (lambda (functional)
+                       (or (eq (functional-kind functional) :deleted)
+                           (when (lambda-p functional)
+                             (or
+                              ;; (The main reason for this first test is to bail
+                              ;; out early in cases where the LAMBDA-COMPONENT
+                              ;; call in the second test would fail because links
+                              ;; it needs are uninitialized or invalid.)
+                              ;;
+                              ;; If the BIND node for this LAMBDA is null, then
+                              ;; according to the slot comments, the LAMBDA has
+                              ;; been deleted or its call has been deleted. In
+                              ;; that case, it seems rather questionable to reuse
+                              ;; it, and certainly it shouldn't be necessary to
+                              ;; reuse it, so we cheerfully declare it invalid.
+                              (not (lambda-bind functional))
+                              ;; If this IR1 stuff belongs to a dead component,
+                              ;; then we can't reuse it without getting into
+                              ;; bizarre confusion.
+                              (eq (component-info (lambda-component functional))
+                                  :dead)))))
+                     (defined-fun-functionals free-fun)))
+    nil))

 
 ;;; If NAME already has a valid entry in *FREE-FUNS*, then return
 ;;; the value. Otherwise, make a new GLOBAL-VAR using information from
 
 ;;; If NAME already has a valid entry in *FREE-FUNS*, then return
 ;;; the value. Otherwise, make a new GLOBAL-VAR using information from

@@ -147,8 +209,9 @@
 (declaim (ftype (sfunction (t string) global-var) find-free-fun))
 (defun find-free-fun (name context)
   (or (let ((old-free-fun (gethash name *free-funs*)))
 (declaim (ftype (sfunction (t string) global-var) find-free-fun))
 (defun find-free-fun (name context)
   (or (let ((old-free-fun (gethash name *free-funs*)))

-        (and (not (invalid-free-fun-p old-free-fun))
-             old-free-fun))
+        (when old-free-fun
+          (clear-invalid-functionals old-free-fun)
+          old-free-fun))

       (ecase (info :function :kind name)
         ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
         (:macro
       (ecase (info :function :kind name)
         ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
         (:macro

@@ -159,19 +222,22 @@
                          context))
         ((:function nil)
          (check-fun-name name)
                          context))
         ((:function nil)
          (check-fun-name name)

-         (note-if-setf-fun-and-macro name)

          (let ((expansion (fun-name-inline-expansion name))
                (inlinep (info :function :inlinep name)))
            (setf (gethash name *free-funs*)
                  (if (or expansion inlinep)
          (let ((expansion (fun-name-inline-expansion name))
                (inlinep (info :function :inlinep name)))
            (setf (gethash name *free-funs*)
                  (if (or expansion inlinep)

-                     (make-defined-fun
-                      :%source-name name
-                      :inline-expansion expansion
-                      :inlinep inlinep
-                      :where-from (info :function :where-from name)
-                      :type (if (eq inlinep :notinline)
-                                (specifier-type 'function)
-                                (info :function :type name)))
+                     (let ((where (info :function :where-from name)))
+                       (make-defined-fun
+                        :%source-name name
+                        :inline-expansion expansion
+                        :inlinep inlinep
+                        :where-from (if (eq inlinep :notinline)
+                                        where
+                                        (maybe-defined-here name where))
+                        :type (if (and (eq inlinep :notinline)
+                                       (neq where :declared))
+                                  (specifier-type 'function)
+                                  (info :function :type name))))

                      (find-global-fun name nil))))))))
 
 ;;; Return the LEAF structure for the lexically apparent function
                      (find-global-fun name nil))))))))
 
 ;;; Return the LEAF structure for the lexically apparent function

@@ -187,6 +253,9 @@
           (t
            (find-free-fun name context)))))
 
           (t
            (find-free-fun name context)))))
 

+(defun maybe-find-free-var (name)
+  (gethash name *free-vars*))
+

 ;;; Return the LEAF node for a global variable reference to NAME. If
 ;;; NAME is already entered in *FREE-VARS*, then we just return the
 ;;; corresponding value. Otherwise, we make a new leaf using
 ;;; Return the LEAF node for a global variable reference to NAME. If
 ;;; NAME is already entered in *FREE-VARS*, then we just return the
 ;;; corresponding value. Otherwise, we make a new leaf using

@@ -200,7 +269,7 @@
       (let ((kind (info :variable :kind name))
             (type (info :variable :type name))
             (where-from (info :variable :where-from name)))
       (let ((kind (info :variable :kind name))
             (type (info :variable :type name))
             (where-from (info :variable :where-from name)))

-        (when (and (eq where-from :assumed) (eq kind :global))
+        (when (eq kind :unknown)

           (note-undefined-reference name :variable))
         (setf (gethash name *free-vars*)
               (case kind
           (note-undefined-reference name :variable))
         (setf (gethash name *free-vars*)
               (case kind

@@ -216,11 +285,20 @@
                        (type (type-specifier (info :variable :type name))))
                    `(macro . (the ,type ,expansion))))
                 (:constant
                        (type (type-specifier (info :variable :type name))))
                    `(macro . (the ,type ,expansion))))
                 (:constant

-                 (let ((value (info :variable :constant-value name)))
-                   (make-constant :value value
-                                  :%source-name name
-                                  :type (ctype-of value)
-                                  :where-from where-from)))
+                 (let ((value (symbol-value name)))
+                   ;; Override the values of standard symbols in XC,
+                   ;; since we can't redefine them.
+                   #+sb-xc-host
+                   (when (eql (find-symbol (symbol-name name) :cl) name)
+                     (multiple-value-bind (xc-value foundp)
+                         (info :variable :xc-constant-value name)
+                       (cond (foundp
+                              (setf value xc-value))
+                             ((not (eq value name))
+                              (compiler-warn
+                               "Using cross-compilation host's definition of ~S: ~A~%"
+                               name (symbol-value name))))))
+                   (find-constant value name)))

                 (t
                  (make-global-var :kind kind
                                   :%source-name name
                 (t
                  (make-global-var :kind kind
                                   :%source-name name

@@ -231,43 +309,27 @@
 ;;; processed with MAKE-LOAD-FORM. We have to be careful, because
 ;;; CONSTANT might be circular. We also check that the constant (and
 ;;; any subparts) are dumpable at all.
 ;;; processed with MAKE-LOAD-FORM. We have to be careful, because
 ;;; CONSTANT might be circular. We also check that the constant (and
 ;;; any subparts) are dumpable at all.

-(eval-when (:compile-toplevel :load-toplevel :execute)
-  ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
-  ;; below. -- AL 20010227
-  (def!constant list-to-hash-table-threshold 32))
-(defun maybe-emit-make-load-forms (constant)
-  (let ((things-processed nil)
-        (count 0))
-    ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit?
-    (declare (type (or list hash-table) things-processed)
-             (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
-             (inline member))
-    (labels ((grovel (value)
+(defun maybe-emit-make-load-forms (constant &optional (name nil namep))
+  (let ((xset (alloc-xset)))
+    (labels ((trivialp (value)
+               (typep value
+                      '(or
+                        #-sb-xc-host unboxed-array
+                        #+sb-xc-host (simple-array (unsigned-byte 8) (*))
+                        symbol
+                        number
+                        character
+                        string
+                        #!+sb-simd-pack
+                        #+sb-xc-host nil
+                        #-sb-xc-host sb!kernel:simd-pack)))
+             (grovel (value)

                ;; Unless VALUE is an object which which obviously
                ;; can't contain other objects
                ;; Unless VALUE is an object which which obviously
                ;; can't contain other objects

-               (unless (typep value
-                              '(or #-sb-xc-host unboxed-array
-                                   #+sb-xc-host (simple-array (unsigned-byte 8) (*))
-                                   symbol
-                                   number
-                                   character
-                                   string))
-                 (etypecase things-processed
-                   (list
-                    (when (member value things-processed :test #'eq)
-                      (return-from grovel nil))
-                    (push value things-processed)
-                    (incf count)
-                    (when (> count list-to-hash-table-threshold)
-                      (let ((things things-processed))
-                        (setf things-processed
-                              (make-hash-table :test 'eq))
-                        (dolist (thing things)
-                          (setf (gethash thing things-processed) t)))))
-                   (hash-table
-                    (when (gethash value things-processed)
-                      (return-from grovel nil))
-                    (setf (gethash value things-processed) t)))
+               (unless (trivialp value)
+                 (if (xset-member-p value xset)
+                     (return-from grovel nil)
+                     (add-to-xset value xset))

                  (typecase value
                    (cons
                     (grovel (car value))
                  (typecase value
                    (cons
                     (grovel (car value))

@@ -288,12 +350,15 @@
                    ((array t)
                     (dotimes (i (array-total-size value))
                       (grovel (row-major-aref value i))))
                    ((array t)
                     (dotimes (i (array-total-size value))
                       (grovel (row-major-aref value i))))

-                   (;; In the target SBCL, we can dump any instance,
-                    ;; but in the cross-compilation host,
-                    ;; %INSTANCE-FOO functions don't work on general
-                    ;; instances, only on STRUCTURE!OBJECTs.
-                    #+sb-xc-host structure!object
+                   (#+sb-xc-host structure!object

                     #-sb-xc-host instance
                     #-sb-xc-host instance

+                    ;; In the target SBCL, we can dump any instance, but
+                    ;; in the cross-compilation host, %INSTANCE-FOO
+                    ;; functions don't work on general instances, only on
+                    ;; STRUCTURE!OBJECTs.
+                    ;;
+                    ;; FIXME: What about funcallable instances with
+                    ;; user-defined MAKE-LOAD-FORM methods?

                     (when (emit-make-load-form value)
                       (dotimes (i (- (%instance-length value)
                                      #+sb-xc-host 0
                     (when (emit-make-load-form value)
                       (dotimes (i (- (%instance-length value)
                                      #+sb-xc-host 0

@@ -304,7 +369,15 @@
                     (compiler-error
                      "Objects of type ~S can't be dumped into fasl files."
                      (type-of value)))))))
                     (compiler-error
                      "Objects of type ~S can't be dumped into fasl files."
                      (type-of value)))))))

-      (grovel constant)))
+      ;; Dump all non-trivial named constants using the name.
+      (if (and namep (not (typep constant '(or symbol character
+                                            ;; FIXME: Cold init breaks if we
+                                            ;; try to reference FP constants
+                                            ;; thru their names.
+                                            #+sb-xc-host number
+                                            #-sb-xc-host fixnum))))
+          (emit-make-load-form constant name)
+          (grovel constant))))

   (values))
 \f
 ;;;; some flow-graph hacking utilities
   (values))
 \f
 ;;;; some flow-graph hacking utilities

@@ -346,6 +419,17 @@
       (error "~S is already a predecessor of ~S." node-block block))
     (push node-block (block-pred block))))
 
       (error "~S is already a predecessor of ~S." node-block block))
     (push node-block (block-pred block))))
 

+;;; Insert NEW before OLD in the flow-graph.
+(defun insert-node-before (old new)
+  (let ((prev (node-prev old))
+        (temp (make-ctran)))
+    (ensure-block-start prev)
+    (setf (ctran-next prev) nil)
+    (link-node-to-previous-ctran new prev)
+    (use-ctran new temp)
+    (link-node-to-previous-ctran old temp))
+  (values))
+

 ;;; This function is used to set the ctran for a node, and thus
 ;;; determine what receives the value.
 (defun use-lvar (node lvar)
 ;;; This function is used to set the ctran for a node, and thus
 ;;; determine what receives the value.
 (defun use-lvar (node lvar)

@@ -404,19 +488,12 @@
     (let* ((forms (if for-value `(,form) `(,form nil)))
            (res (ir1-convert-lambda-body
                  forms ()
     (let* ((forms (if for-value `(,form) `(,form nil)))
            (res (ir1-convert-lambda-body
                  forms ()

-                 :debug-name (debug-name 'top-level-form form))))
+                 :debug-name (debug-name 'top-level-form #+sb-xc-host nil #-sb-xc-host form))))

       (setf (functional-entry-fun res) res
             (functional-arg-documentation res) ()
             (functional-kind res) :toplevel)
       res)))
 
       (setf (functional-entry-fun res) res
             (functional-arg-documentation res) ()
             (functional-kind res) :toplevel)
       res)))
 

-;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the
-;;; form number to associate with a source path. This should be bound
-;;; to an initial value of 0 before the processing of each truly
-;;; top level form.
-(declaim (type index *current-form-number*))
-(defvar *current-form-number*)
-

 ;;; This function is called on freshly read forms to record the
 ;;; initial location of each form (and subform.) Form is the form to
 ;;; find the paths in, and TLF-NUM is the top level form number of the
 ;;; This function is called on freshly read forms to record the
 ;;; initial location of each form (and subform.) Form is the form to
 ;;; find the paths in, and TLF-NUM is the top level form number of the

@@ -430,28 +507,27 @@
     (sub-find-source-paths form (list tlf-num)))
   (values))
 (defun sub-find-source-paths (form path)
     (sub-find-source-paths form (list tlf-num)))
   (values))
 (defun sub-find-source-paths (form path)

-  (unless (gethash form *source-paths*)
-    (setf (gethash form *source-paths*)
-          (list* 'original-source-start *current-form-number* path))
+  (unless (get-source-path form)
+    (note-source-path form path)

     (incf *current-form-number*)
     (let ((pos 0)
           (subform form)
           (trail form))
       (declare (fixnum pos))
       (macrolet ((frob ()
     (incf *current-form-number*)
     (let ((pos 0)
           (subform form)
           (trail form))
       (declare (fixnum pos))
       (macrolet ((frob ()

-                   '(progn
+                   `(progn

                       (when (atom subform) (return))
                       (let ((fm (car subform)))
                       (when (atom subform) (return))
                       (let ((fm (car subform)))

-                        (if (consp fm)
-                            ;; If it's a cons, recurse
-                            (sub-find-source-paths fm (cons pos path))
-                            ;; Otherwise store the containing form. It's
-                            ;; not perfect, but better than nothing.
-                            (setf (gethash subform *source-paths*)
-                                  (list* 'original-source-start
-                                         *current-form-number*
-                                         pos
-                                         path)))
+                        (cond ((consp fm)
+                               ;; If it's a cons, recurse.
+                               (sub-find-source-paths fm (cons pos path)))
+                              ((eq 'quote fm)
+                               ;; Don't look into quoted constants.
+                               (return))
+                              ((not (zerop pos))
+                               ;; Otherwise store the containing form. It's not
+                               ;; perfect, but better than nothing.
+                               (note-source-path subform pos path)))

                         (incf pos))
                       (setq subform (cdr subform))
                       (when (eq subform trail) (return)))))
                         (incf pos))
                       (setq subform (cdr subform))
                       (when (eq subform trail) (return)))))

@@ -462,7 +538,8 @@
 \f
 ;;;; IR1-CONVERT, macroexpansion and special form dispatching
 
 \f
 ;;;; IR1-CONVERT, macroexpansion and special form dispatching
 

-(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t &optional t)
+                           (values))

                 ir1-convert))
 (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
            ;; out of the body and converts a condition signalling form
                 ir1-convert))
 (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
            ;; out of the body and converts a condition signalling form

@@ -491,10 +568,9 @@
   ;; the creation using backquote of forms that contain leaf
   ;; references, without having to introduce dummy names into the
   ;; namespace.
   ;; the creation using backquote of forms that contain leaf
   ;; references, without having to introduce dummy names into the
   ;; namespace.

-  (defun ir1-convert (start next result form)
+  (defun ir1-convert (start next result form &optional alias)

     (ir1-error-bailout (start next result form)
     (ir1-error-bailout (start next result form)

-      (let* ((*current-path* (or (gethash form *source-paths*)
-                                 (cons form *current-path*)))
+      (let* ((*current-path* (ensure-source-path (or alias form)))

              (start (instrument-coverage start nil form)))
         (cond ((atom form)
                (cond ((and (symbolp form) (not (keywordp form)))
              (start (instrument-coverage start nil form)))
         (cond ((atom form)
                (cond ((and (symbolp form) (not (keywordp form)))

@@ -508,21 +584,16 @@
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf

-  ;; if necessary. If we are producing a fasl file, make sure that
-  ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
-  ;; needs to be.
+  ;; if necessary.

   (defun reference-constant (start next result value)
     (declare (type ctran start next)
   (defun reference-constant (start next result value)
     (declare (type ctran start next)

-             (type (or lvar null) result)
-             (inline find-constant))
+             (type (or lvar null) result))

     (ir1-error-bailout (start next result value)
     (ir1-error-bailout (start next result value)

-     (when (producing-fasl-file)
-       (maybe-emit-make-load-forms value))
-     (let* ((leaf (find-constant value))
-            (res (make-ref leaf)))
-       (push res (leaf-refs leaf))
-       (link-node-to-previous-ctran res start)
-       (use-continuation res next result)))
+      (let* ((leaf (find-constant value))
+             (res (make-ref leaf)))
+        (push res (leaf-refs leaf))
+        (link-node-to-previous-ctran res start)
+        (use-continuation res next result)))

     (values)))
 
 ;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
     (values)))
 
 ;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's

@@ -552,31 +623,22 @@
 ;;; needed. If LEAF represents a defined function which has already
 ;;; been converted, and is not :NOTINLINE, then reference the
 ;;; functional instead.
 ;;; needed. If LEAF represents a defined function which has already
 ;;; been converted, and is not :NOTINLINE, then reference the
 ;;; functional instead.

-(defun reference-leaf (start next result leaf)
+(defun reference-leaf (start next result leaf &optional (name '.anonymous.))

   (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf))
   (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf))

-  (when (functional-p leaf)
-    (assure-functional-live-p leaf))
+  (assure-leaf-live-p leaf)

   (let* ((type (lexenv-find leaf type-restrictions))
          (leaf (or (and (defined-fun-p leaf)
                         (not (eq (defined-fun-inlinep leaf)
                                  :notinline))
                         (let ((functional (defined-fun-functional leaf)))
   (let* ((type (lexenv-find leaf type-restrictions))
          (leaf (or (and (defined-fun-p leaf)
                         (not (eq (defined-fun-inlinep leaf)
                                  :notinline))
                         (let ((functional (defined-fun-functional leaf)))

-                          (when (and functional
-                                     (not (functional-kind functional))
-                                     ;; Bug MISC.320: ir1-transform
-                                     ;; can create a reference to a
-                                     ;; inline-expanded function,
-                                     ;; defined in another component.
-                                     (not (and (lambda-p functional)
-                                               (neq (lambda-component functional)
-                                                    *current-component*))))
+                          (when (and functional (not (functional-kind functional)))

                             (maybe-reanalyze-functional functional))))
                    (when (and (lambda-p leaf)
                               (memq (functional-kind leaf)
                                     '(nil :optional)))
                      (maybe-reanalyze-functional leaf))
                    leaf))
                             (maybe-reanalyze-functional functional))))
                    (when (and (lambda-p leaf)
                               (memq (functional-kind leaf)
                                     '(nil :optional)))
                      (maybe-reanalyze-functional leaf))
                    leaf))

-         (ref (make-ref leaf)))
+         (ref (make-ref leaf name)))

     (push ref (leaf-refs leaf))
     (setf (leaf-ever-used leaf) t)
     (link-node-to-previous-ctran ref start)
     (push ref (leaf-refs leaf))
     (setf (leaf-ever-used leaf) t)
     (link-node-to-previous-ctran ref start)

@@ -598,11 +660,15 @@
 (defun ir1-convert-var (start next result name)
   (declare (type ctran start next) (type (or lvar null) result) (symbol name))
   (let ((var (or (lexenv-find name vars) (find-free-var name))))
 (defun ir1-convert-var (start next result name)
   (declare (type ctran start next) (type (or lvar null) result) (symbol name))
   (let ((var (or (lexenv-find name vars) (find-free-var name))))

-    (if (and (global-var-p var) (not result))
-        ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE
-        ;; which is not flushable, so that unbound dead variables signal
-        ;; an error (bug 412).
-        (ir1-convert start next result `(symbol-value ',name))
+    (if (and (global-var-p var) (not (info :variable :always-bound name)))
+        ;; KLUDGE: If the variable may be unbound, convert using SYMBOL-VALUE
+        ;; which is not flushable, so that unbound dead variables signal an
+        ;; error (bug 412, lp#722734): checking for null RESULT is not enough,
+        ;; since variables can become dead due to later optimizations.
+        (ir1-convert start next result
+                     (if (eq (global-var-kind var) :global)
+                         `(symbol-global-value ',name)
+                         `(symbol-value ',name)))

         (etypecase var
           (leaf
            (when (lambda-var-p var)
         (etypecase var
           (leaf
            (when (lambda-var-p var)

@@ -618,7 +684,9 @@
                ;; processing our own code, though.
                #+sb-xc-host
                (warn "reading an ignored variable: ~S" name)))
                ;; processing our own code, though.
                #+sb-xc-host
                (warn "reading an ignored variable: ~S" name)))

-           (reference-leaf start next result var))
+           (when (global-var-p var)
+             (check-deprecated-variable name))
+           (reference-leaf start next result var name))

           (cons
            (aver (eq (car var) 'macro))
            ;; FIXME: [Free] type declarations. -- APD, 2002-01-26
           (cons
            (aver (eq (car var) 'macro))
            ;; FIXME: [Free] type declarations. -- APD, 2002-01-26

@@ -631,7 +699,8 @@
 (defun find-compiler-macro (opname form)
   (if (eq opname 'funcall)
       (let ((fun-form (cadr form)))
 (defun find-compiler-macro (opname form)
   (if (eq opname 'funcall)
       (let ((fun-form (cadr form)))

-        (cond ((and (consp fun-form) (eq 'function (car fun-form)))
+        (cond ((and (consp fun-form) (eq 'function (car fun-form))
+                    (not (cddr fun-form)))

                (let ((real-fun (cadr fun-form)))
                  (if (legal-fun-name-p real-fun)
                      (values (sb!xc:compiler-macro-function real-fun *lexenv*)
                (let ((real-fun (cadr fun-form)))
                  (if (legal-fun-name-p real-fun)
                      (values (sb!xc:compiler-macro-function real-fun *lexenv*)

@@ -668,11 +737,17 @@
                       ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
                       ;; suppresses compiler-macros.
                       (not (fun-lexically-notinline-p cmacro-fun-name)))
                       ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
                       ;; suppresses compiler-macros.
                       (not (fun-lexically-notinline-p cmacro-fun-name)))

-                 (let ((res (careful-expand-macro cmacro-fun form)))
-                   (if (eq res form)
-                       (ir1-convert-common-functoid start next result form
-                                                    op)
-                       (ir1-convert start next result res)))
+                 (let ((res (handler-case
+                                (careful-expand-macro cmacro-fun form t)
+                              (compiler-macro-keyword-problem (c)
+                                (print-compiler-message *error-output* "note: ~A" (list c))
+                                form))))
+                   (cond ((eq res form)
+                          (ir1-convert-common-functoid start next result form op))
+                         (t
+                          (unless (policy *lexenv* (zerop store-xref-data))
+                            (record-call cmacro-fun-name (ctran-block start) *current-path*))
+                          (ir1-convert start next result res))))

                  (ir1-convert-common-functoid start next result form op)))))))
 
 ;;; Handles the "common" cases: any other forms except special forms
                  (ir1-convert-common-functoid start next result form op)))))))
 
 ;;; Handles the "common" cases: any other forms except special forms

@@ -697,10 +772,7 @@
         (t
          ;; implicitly (LAMBDA ..) because the LAMBDA expression is
          ;; the CAR of an executed form.
         (t
          ;; implicitly (LAMBDA ..) because the LAMBDA expression is
          ;; the CAR of an executed form.

-         (ir1-convert-combination
-          start next result form
-          (ir1-convert-lambda op
-                              :debug-name (debug-name 'inline-lambda op))))))
+         (ir1-convert start next result `(%funcall ,@form)))))

 
 ;;; Convert anything that looks like a global function call.
 (defun ir1-convert-global-functoid (start next result form fun)
 
 ;;; Convert anything that looks like a global function call.
 (defun ir1-convert-global-functoid (start next result form fun)

@@ -727,69 +799,66 @@
 
 ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
 ;;; errors which occur during the macroexpansion.
 
 ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
 ;;; errors which occur during the macroexpansion.

-(defun careful-expand-macro (fun form)
-  (let (;; a hint I (WHN) wish I'd known earlier
-        (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)"))
-    (flet (;; Return a string to use as a prefix in error reporting,
-           ;; telling something about which form caused the problem.
-           (wherestring ()
-             (let ((*print-pretty* nil)
-                   ;; We rely on the printer to abbreviate FORM.
-                   (*print-length* 3)
-                   (*print-level* 1))
-               (format
-                nil
-                #-sb-xc-host "(in macroexpansion of ~S)"
-                ;; longer message to avoid ambiguity "Was it the xc host
-                ;; or the cross-compiler which encountered the problem?"
-                #+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
-                form))))
-      (handler-bind ((style-warning (lambda (c)
-                                      (compiler-style-warn
-                                       "~@<~A~:@_~A~@:_~A~:>"
-                                       (wherestring) hint c)
-                                      (muffle-warning-or-die)))
-                     ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
-                     ;; Debian Linux, anyway) raises a CL:WARNING
-                     ;; condition (not a CL:STYLE-WARNING) for undefined
-                     ;; symbols when converting interpreted functions,
-                     ;; causing COMPILE-FILE to think the file has a real
-                     ;; problem, causing COMPILE-FILE to return FAILURE-P
-                     ;; set (not just WARNINGS-P set). Since undefined
-                     ;; symbol warnings are often harmless forward
-                     ;; references, and since it'd be inordinately painful
-                     ;; to try to eliminate all such forward references,
-                     ;; these warnings are basically unavoidable. Thus, we
-                     ;; need to coerce the system to work through them,
-                     ;; and this code does so, by crudely suppressing all
-                     ;; warnings in cross-compilation macroexpansion. --
-                     ;; WHN 19990412
-                     #+(and cmu sb-xc-host)
-                     (warning (lambda (c)
-                                (compiler-notify
-                                 "~@<~A~:@_~
-                                  ~A~:@_~
-                                  ~@<(KLUDGE: That was a non-STYLE WARNING. ~
-                                  Ordinarily that would cause compilation to ~
-                                  fail. However, since we're running under ~
-                                  CMU CL, and since CMU CL emits non-STYLE ~
-                                  warnings for safe, hard-to-fix things (e.g. ~
-                                  references to not-yet-defined functions) ~
-                                  we're going to have to ignore it and ~
-                                  proceed anyway. Hopefully we're not ~
-                                  ignoring anything  horrible here..)~:@>~:>"
-                                 (wherestring)
-                                 c)
-                                (muffle-warning-or-die)))
-                     #-(and cmu sb-xc-host)
-                     (warning (lambda (c)
-                                (warn "~@<~A~:@_~A~@:_~A~:>"
-                                      (wherestring) hint c)
-                                (muffle-warning-or-die)))
-                     (error (lambda (c)
-                              (compiler-error "~@<~A~:@_~A~@:_~A~:>"
-                                              (wherestring) hint c))))
-        (funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))))
+(defun careful-expand-macro (fun form &optional cmacro)
+  (flet (;; Return a string to use as a prefix in error reporting,
+         ;; telling something about which form caused the problem.
+         (wherestring ()
+           (let (;; We rely on the printer to abbreviate FORM.
+                 (*print-length* 3)
+                 (*print-level* 3))
+             (format nil
+                     "~@<~A of ~S. Use ~S to intercept.~%~:@>"
+                     (cond (cmacro
+                            #-sb-xc-host "Error during compiler-macroexpansion"
+                            #+sb-xc-host "Error during XC compiler-macroexpansion")
+                           (t
+                            #-sb-xc-host "during macroexpansion"
+                            #+sb-xc-host "during XC macroexpansion"))
+                     form
+                     '*break-on-signals*))))
+    (handler-bind (;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for Debian
+                   ;; Linux, anyway) raises a CL:WARNING condition (not a
+                   ;; CL:STYLE-WARNING) for undefined symbols when converting
+                   ;; interpreted functions, causing COMPILE-FILE to think the
+                   ;; file has a real problem, causing COMPILE-FILE to return
+                   ;; FAILURE-P set (not just WARNINGS-P set). Since undefined
+                   ;; symbol warnings are often harmless forward references,
+                   ;; and since it'd be inordinately painful to try to
+                   ;; eliminate all such forward references, these warnings
+                   ;; are basically unavoidable. Thus, we need to coerce the
+                   ;; system to work through them, and this code does so, by
+                   ;; crudely suppressing all warnings in cross-compilation
+                   ;; macroexpansion. -- WHN 19990412
+                   #+(and cmu sb-xc-host)
+                   (warning (lambda (c)
+                              (compiler-notify
+                               "~@<~A~:@_~
+                                ~A~:@_~
+                                ~@<(KLUDGE: That was a non-STYLE WARNING. ~
+                                   Ordinarily that would cause compilation to ~
+                                   fail. However, since we're running under ~
+                                   CMU CL, and since CMU CL emits non-STYLE ~
+                                   warnings for safe, hard-to-fix things (e.g. ~
+                                   references to not-yet-defined functions) ~
+                                   we're going to have to ignore it and ~
+                                   proceed anyway. Hopefully we're not ~
+                                   ignoring anything  horrible here..)~:@>~:>"
+                               (wherestring)
+                               c)
+                              (muffle-warning-or-die)))
+                   (error
+                     (lambda (c)
+                       (cond
+                         (cmacro
+                          ;; The spec is silent on what we should do. Signaling
+                          ;; a full warning but declining to expand seems like
+                          ;; a conservative and sane thing to do.
+                          (compiler-warn "~@<~A~@:_ ~A~:>" (wherestring) c)
+                          (return-from careful-expand-macro form))
+                         (t
+                          (compiler-error "~@<~A~@:_ ~A~:>"
+                                          (wherestring) c))))))
+      (funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))

 \f
 ;;;; conversion utilities
 
 \f
 ;;;; conversion utilities
 

@@ -820,7 +889,7 @@
 
 ;;; Check the policy for whether we should generate code coverage
 ;;; instrumentation. If not, just return the original START
 
 ;;; Check the policy for whether we should generate code coverage
 ;;; instrumentation. If not, just return the original START

-;;; ctran. Otherwise ninsert code coverage instrumentation after
+;;; ctran. Otherwise insert code coverage instrumentation after

 ;;; START, and return the new ctran.
 (defun instrument-coverage (start mode form)
   ;; We don't actually use FORM for anything, it's just convenient to
 ;;; START, and return the new ctran.
 (defun instrument-coverage (start mode form)
   ;; We don't actually use FORM for anything, it's just convenient to

@@ -843,7 +912,7 @@
                    ;; each instrument for the same block.
                    (or (gethash path *code-coverage-records*)
                        (setf (gethash path *code-coverage-records*)
                    ;; each instrument for the same block.
                    (or (gethash path *code-coverage-records*)
                        (setf (gethash path *code-coverage-records*)

-                             (cons path nil))))
+                             (cons path +code-coverage-unmarked+))))

                   (next (make-ctran))
                   (*allow-instrumenting* nil))
               (push (ctran-block start)
                   (next (make-ctran))
                   (*allow-instrumenting* nil))
               (push (ctran-block start)

@@ -853,7 +922,8 @@
                              `(locally
                                   (declare (optimize speed
                                                      (safety 0)
                              `(locally
                                   (declare (optimize speed
                                                      (safety 0)

-                                                     (debug 0)))
+                                                     (debug 0)
+                                                     (check-constant-modification 0)))

                                 ;; We're being naughty here, and
                                 ;; modifying constant data. That's ok,
                                 ;; we know what we're doing.
                                 ;; We're being naughty here, and
                                 ;; modifying constant data. That's ok,
                                 ;; we know what we're doing.

@@ -870,10 +940,10 @@
 ;;; EQness of the conses.
 (defun maybe-instrument-progn-like (start forms form)
   (or (when (and *allow-instrumenting*
 ;;; EQness of the conses.
 (defun maybe-instrument-progn-like (start forms form)
   (or (when (and *allow-instrumenting*

-                 (not (gethash form *source-paths*)))
-        (let ((*current-path* (gethash forms *source-paths*)))
+                 (not (get-source-path form)))
+        (let ((*current-path* (get-source-path forms)))

           (when *current-path*
           (when *current-path*

-            (instrument-coverage start :progn form))))
+            (instrument-coverage start nil form))))

       start))
 
 (defun record-code-coverage (info cc)
       start))
 
 (defun record-code-coverage (info cc)

@@ -886,9 +956,15 @@
   (maphash (lambda (info cc)
              (declare (ignore info))
              (dolist (cc-entry cc)
   (maphash (lambda (info cc)
              (declare (ignore info))
              (dolist (cc-entry cc)

-               (setf (cdr cc-entry) nil)))
+               (setf (cdr cc-entry) +code-coverage-unmarked+)))

            *code-coverage-info*))
 
            *code-coverage-info*))
 

+(defun code-coverage-record-marked (record)
+  (aver (consp record))
+  (ecase (cdr record)
+    ((#.+code-coverage-unmarked+) nil)
+    ((t) t)))
+

 \f
 ;;;; converting combinations
 
 \f
 ;;;; converting combinations
 

@@ -896,12 +972,18 @@
 ;;; instrumentation for?
 (defun step-form-p (form)
   (flet ((step-symbol-p (symbol)
 ;;; instrumentation for?
 (defun step-form-p (form)
   (flet ((step-symbol-p (symbol)

-           (not (member (symbol-package symbol)
-                        (load-time-value
-                         ;; KLUDGE: packages we're not interested in
-                         ;; stepping.
-                         (mapcar #'find-package '(sb!c sb!int sb!impl
-                                                  sb!kernel sb!pcl)))))))
+           (and (not (member (symbol-package symbol)
+                             (load-time-value
+                              ;; KLUDGE: packages we're not interested in
+                              ;; stepping.
+                              (mapcar #'find-package '(sb!c sb!int sb!impl
+                                                       sb!kernel sb!pcl)))))
+                ;; Consistent treatment of *FOO* vs (SYMBOL-VALUE '*FOO*):
+                ;; we insert calls to SYMBOL-VALUE for most non-lexical
+                ;; variable references in order to avoid them being elided
+                ;; if the value is unused.
+                (or (not (member symbol '(symbol-value symbol-global-value)))
+                    (not (constantp (second form)))))))

     (and *allow-instrumenting*
          (policy *lexenv* (= insert-step-conditions 3))
          (listp form)
     (and *allow-instrumenting*
          (policy *lexenv* (= insert-step-conditions 3))
          (listp form)

@@ -972,14 +1054,16 @@
                    (defined-fun-inlinep var))))
     (if (eq inlinep :notinline)
         (ir1-convert-combination start next result form var)
                    (defined-fun-inlinep var))))
     (if (eq inlinep :notinline)
         (ir1-convert-combination start next result form var)

-        (let ((transform (info :function
-                               :source-transform
-                               (leaf-source-name var))))
+        (let* ((name (leaf-source-name var))
+               (transform (info :function :source-transform name)))

           (if transform
               (multiple-value-bind (transformed pass) (funcall transform form)
           (if transform
               (multiple-value-bind (transformed pass) (funcall transform form)

-                (if pass
-                    (ir1-convert-maybe-predicate start next result form var)
-                    (ir1-convert start next result transformed)))
+                (cond (pass
+                       (ir1-convert-maybe-predicate start next result form var))
+                      (t
+                       (unless (policy *lexenv* (zerop store-xref-data))
+                         (record-call name (ctran-block start) *current-path*))
+                       (ir1-convert start next result transformed))))

               (ir1-convert-maybe-predicate start next result form var))))))
 
 ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE
               (ir1-convert-maybe-predicate start next result form var))))))
 
 ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE

@@ -1026,7 +1110,7 @@
   (let* ((node (ir1-convert-combination start next result form var))
          (fun-lvar (basic-combination-fun node))
          (type (leaf-type var)))
   (let* ((node (ir1-convert-combination start next result form var))
          (fun-lvar (basic-combination-fun node))
          (type (leaf-type var)))

-    (when (validate-call-type node type t)
+    (when (validate-call-type node type var t)

       (setf (lvar-%derived-type fun-lvar)
             (make-single-value-type type))
       (setf (lvar-reoptimize fun-lvar) nil)))
       (setf (lvar-%derived-type fun-lvar)
             (make-single-value-type type))
       (setf (lvar-reoptimize fun-lvar) nil)))

@@ -1106,7 +1190,9 @@
                                  (type-specifier old-type)
                                  (type-specifier type)
                                  var-name))))
                                  (type-specifier old-type)
                                  (type-specifier type)
                                  var-name))))

-                            (bound-var (setf (leaf-type bound-var) int))
+                            (bound-var
+                             (setf (leaf-type bound-var) int
+                                   (leaf-where-from bound-var) :declared))

                             (t
                              (restr (cons var int)))))))
                (process-var var bound-var)
                             (t
                              (restr (cons var int)))))))
                (process-var var bound-var)

@@ -1138,6 +1224,9 @@
   (declare (type list names fvars)
            (type lexenv res))
   (let ((type (compiler-specifier-type spec)))
   (declare (type list names fvars)
            (type lexenv res))
   (let ((type (compiler-specifier-type spec)))

+    (unless (csubtypep type (specifier-type 'function))
+      (compiler-style-warn "ignoring declared FTYPE: ~S (not a function type)" spec)
+      (return-from process-ftype-decl res))

     (collect ((res nil cons))
       (dolist (name names)
         (when (fboundp name)
     (collect ((res nil cons))
       (dolist (name names)
         (when (fboundp name)

@@ -1166,6 +1255,16 @@
   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))
   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))

+      ;; While CLHS seems to allow local SPECIAL declarations for constants,
+      ;; whatever the semantics are supposed to be is not at all clear to me
+      ;; -- since constants aren't allowed to be bound it should be a no-op as
+      ;; no-one can observe the difference portably, but specials are allowed
+      ;; to be bound... yet nowhere does it say that the special declaration
+      ;; removes the constantness. Call it a spec bug and prohibit it. Same
+      ;; for GLOBAL variables.
+      (let ((kind (info :variable :kind name)))
+        (unless (member kind '(:special :unknown))
+          (error "Can't declare ~(~A~) variable locally special: ~S" kind name)))

       (program-assert-symbol-home-package-unlocked
        context name "declaring ~A special")
       (let ((var (find-in-bindings vars name)))
       (program-assert-symbol-home-package-unlocked
        context name "declaring ~A special")
       (let ((var (find-in-bindings vars name)))

@@ -1214,8 +1313,8 @@
     (when (defined-fun-p var)
       (setf (defined-fun-inline-expansion res)
             (defined-fun-inline-expansion var))
     (when (defined-fun-p var)
       (setf (defined-fun-inline-expansion res)
             (defined-fun-inline-expansion var))

-      (setf (defined-fun-functional res)
-            (defined-fun-functional var)))
+      (setf (defined-fun-functionals res)
+            (defined-fun-functionals var)))

     ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
     ;; to the original global-var?
     res))
     ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
     ;; to the original global-var?
     res))

@@ -1249,13 +1348,13 @@
 ;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
 (defun find-in-bindings-or-fbindings (name vars fvars)
   (declare (list vars fvars))
 ;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
 (defun find-in-bindings-or-fbindings (name vars fvars)
   (declare (list vars fvars))

-  (if (consp name)
-      (destructuring-bind (wot fn-name) name
-        (unless (eq wot 'function)
-          (compiler-error "The function or variable name ~S is unrecognizable."
-                          name))
-        (find fn-name fvars :key #'leaf-source-name :test #'equal))
-      (find-in-bindings vars name)))
+  (typecase name
+    (atom
+     (find-in-bindings vars name))
+    ((cons (eql function) (cons * null))
+     (find (cadr name) fvars :key #'leaf-source-name :test #'equal))
+    (t
+     (compiler-error "Malformed function or variable name ~S." name))))

 
 ;;; Process an ignore/ignorable declaration, checking for various losing
 ;;; conditions.
 
 ;;; Process an ignore/ignorable declaration, checking for various losing
 ;;; conditions.

@@ -1264,76 +1363,106 @@
   (dolist (name (rest spec))
     (let ((var (find-in-bindings-or-fbindings name vars fvars)))
       (cond
   (dolist (name (rest spec))
     (let ((var (find-in-bindings-or-fbindings name vars fvars)))
       (cond

-       ((not var)
-        ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
-        ;; requires that this be a STYLE-WARNING, not a full WARNING.
-        (compiler-style-warn "declaring unknown variable ~S to be ignored"
-                             name))
-       ;; FIXME: This special case looks like non-ANSI weirdness.
-       ((and (consp var) (eq (car var) 'macro))
-        ;; Just ignore the IGNORE decl.
-        )
-       ((functional-p var)
-        (setf (leaf-ever-used var) t))
-       ((and (lambda-var-specvar var) (eq (first spec) 'ignore))
-        ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
-        ;; requires that this be a STYLE-WARNING, not a full WARNING.
-        (compiler-style-warn "declaring special variable ~S to be ignored"
-                             name))
-       ((eq (first spec) 'ignorable)
-        (setf (leaf-ever-used var) t))
-       (t
-        (setf (lambda-var-ignorep var) t)))))
+        ((not var)
+         ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
+         ;; requires that this be a STYLE-WARNING, not a full WARNING.
+         (multiple-value-call #'compiler-style-warn
+           "~A declaration for ~A: ~A"
+           (first spec)
+           (if (symbolp name)
+               (values
+                (case (info :variable :kind name)
+                  (:special "a special variable")
+                  (:global "a global lexical variable")
+                  (:alien "a global alien variable")
+                  (t "an unknown variable"))
+                name)
+               (values
+                (if (info :function :kind (second name))
+                    "a global function"
+                    "an unknown function")
+                (second name)))))
+        ((and (consp var) (eq (car var) 'macro))
+         ;; Just ignore the IGNORE decl: we don't currently signal style-warnings
+         ;; for unused symbol-macros, so there's no need to do anything.
+         )
+        ((functional-p var)
+         (setf (leaf-ever-used var) t))
+        ((and (lambda-var-specvar var) (eq (first spec) 'ignore))
+         ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
+         ;; requires that this be a STYLE-WARNING, not a full WARNING.
+         (compiler-style-warn "Declaring special variable ~S to be ~A"
+                              name
+                              (first spec)))
+        ((eq (first spec) 'ignorable)
+         (setf (leaf-ever-used var) t))
+        (t
+         (setf (lambda-var-ignorep var) t)))))

   (values))
 
   (values))
 

-(defun process-dx-decl (names vars fvars)
-  (flet ((maybe-notify (control &rest args)
-           (when (policy *lexenv* (> speed inhibit-warnings))
-             (apply #'compiler-notify control args))))
-    (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
+(defun process-extent-decl (names vars fvars kind)
+  (let ((extent
+          (ecase kind
+            (truly-dynamic-extent
+             :always-dynamic)
+            (dynamic-extent
+             (when *stack-allocate-dynamic-extent*
+               :maybe-dynamic))
+            (indefinite-extent
+             :indefinite))))
+    (if extent

         (dolist (name names)
           (cond
             ((symbolp name)
              (let* ((bound-var (find-in-bindings vars name))
                     (var (or bound-var
                              (lexenv-find name vars)
         (dolist (name names)
           (cond
             ((symbolp name)
              (let* ((bound-var (find-in-bindings vars name))
                     (var (or bound-var
                              (lexenv-find name vars)

-                             (find-free-var name))))
+                             (maybe-find-free-var name))))

                (etypecase var
                  (leaf
                   (if bound-var
                (etypecase var
                  (leaf
                   (if bound-var

-                      (setf (leaf-dynamic-extent var) t)
-                      (maybe-notify
-                       "ignoring DYNAMIC-EXTENT declaration for free ~S"
-                       name)))
+                      (if (and (leaf-extent var) (neq extent (leaf-extent var)))
+                          (warn "Multiple incompatible extent declarations for ~S?" name)
+                          (setf (leaf-extent var) extent))
+                      (compiler-notify
+                       "Ignoring free ~S declaration: ~S" kind name)))

                  (cons
                  (cons

-                  (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+                  (compiler-error "~S on symbol-macro: ~S" kind name))

                  (heap-alien-info
                  (heap-alien-info

-                  (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
-                                  name)))))
+                  (compiler-error "~S on alien-variable: ~S" kind name))
+                 (null
+                  (compiler-style-warn
+                   "Unbound variable declared ~S: ~S" kind name)))))

             ((and (consp name)
                   (eq (car name) 'function)
                   (null (cddr name))
             ((and (consp name)
                   (eq (car name) 'function)
                   (null (cddr name))

-                  (valid-function-name-p (cadr name)))
+                  (valid-function-name-p (cadr name))
+                  (neq :indefinite extent))

              (let* ((fname (cadr name))
                     (bound-fun (find fname fvars
                                      :key #'leaf-source-name
              (let* ((fname (cadr name))
                     (bound-fun (find fname fvars
                                      :key #'leaf-source-name

-                                     :test #'equal)))
-               (etypecase bound-fun
+                                     :test #'equal))
+                    (fun (or bound-fun (lexenv-find fname funs))))
+               (etypecase fun

                  (leaf
                  (leaf

-                  #!+stack-allocatable-closures
-                  (setf (leaf-dynamic-extent bound-fun) t)
-                  #!-stack-allocatable-closures
-                  (maybe-notify
-                   "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
-                    (not supported on this platform)." fname))
+                  (if bound-fun
+                      #!+stack-allocatable-closures
+                      (setf (leaf-extent bound-fun) extent)
+                      #!-stack-allocatable-closures
+                      (compiler-notify
+                       "Ignoring DYNAMIC-EXTENT declaration on function ~S ~
+                        (not supported on this platform)." fname)
+                      (compiler-notify
+                       "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))

                  (cons
                  (cons

-                  (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
+                  (compiler-error "DYNAMIC-EXTENT on macro: ~S" name))

                  (null
                  (null

-                  (maybe-notify
-                   "ignoring DYNAMIC-EXTENT declaration for free ~S"
-                   fname)))))
-            (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
-      (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+                  (compiler-style-warn
+                   "Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
+            (t
+             (compiler-error "~S on a weird thing: ~S" kind name))))
+        (when (policy *lexenv* (= speed 3))
+          (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))

 
 ;;; FIXME: This is non-ANSI, so the default should be T, or it should
 ;;; go away, I think.
 
 ;;; FIXME: This is non-ANSI, so the default should be T, or it should
 ;;; go away, I think.

@@ -1386,8 +1515,8 @@
                        (car types)
                        `(values ,@types)))))
           res))
                        (car types)
                        `(values ,@types)))))
           res))

-       (dynamic-extent
-        (process-dx-decl (cdr spec) vars fvars)
+       ((dynamic-extent truly-dynamic-extent indefinite-extent)
+        (process-extent-decl (cdr spec) vars fvars (first spec))

         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv
         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv

@@ -1397,7 +1526,10 @@
        (t
         (unless (info :declaration :recognized (first spec))
           (compiler-warn "unrecognized declaration ~S" raw-spec))
        (t
         (unless (info :declaration :recognized (first spec))
           (compiler-warn "unrecognized declaration ~S" raw-spec))

-        res))
+        (let ((fn (info :declaration :handler (first spec))))
+          (if fn
+              (funcall fn res spec vars fvars)
+              res))))

      result-type)))
 
 ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
      result-type)))
 
 ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR

@@ -1418,14 +1550,20 @@
         (*post-binding-variable-lexenv* nil))
     (dolist (decl decls)
       (dolist (spec (rest decl))
         (*post-binding-variable-lexenv* nil))
     (dolist (decl decls)
       (dolist (spec (rest decl))

-        (unless (consp spec)
-          (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
-        (multiple-value-bind (new-env new-result-type)
-            (process-1-decl spec lexenv vars fvars binding-form-p context)
-          (setq lexenv new-env)
-          (unless (eq new-result-type *wild-type*)
-            (setq result-type
-                  (values-type-intersection result-type new-result-type))))))
+        (progv
+            ;; Kludge: EVAL calls this function to deal with LOCALLY.
+            (when (eq context :compile) (list '*current-path*))
+            (when (eq context :compile) (list (or (get-source-path spec)
+                                                  (get-source-path decl)
+                                                  *current-path*)))
+          (unless (consp spec)
+            (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
+          (multiple-value-bind (new-env new-result-type)
+              (process-1-decl spec lexenv vars fvars binding-form-p context)
+            (setq lexenv new-env)
+            (unless (eq new-result-type *wild-type*)
+              (setq result-type
+                    (values-type-intersection result-type new-result-type)))))))

     (values lexenv result-type *post-binding-variable-lexenv*)))
 
 (defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun)
     (values lexenv result-type *post-binding-variable-lexenv*)))
 
 (defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun)

@@ -1449,7 +1587,7 @@
   (check-type ctran symbol)
   (check-type lvar symbol)
   (let ((post-binding-lexenv-p (not (null post-binding-lexenv)))
   (check-type ctran symbol)
   (check-type lvar symbol)
   (let ((post-binding-lexenv-p (not (null post-binding-lexenv)))

-        (post-binding-lexenv (or post-binding-lexenv (gensym))))
+        (post-binding-lexenv (or post-binding-lexenv (sb!xc:gensym "LEXENV"))))

     `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
                         ,post-binding-lexenv-p
                         (lambda (,ctran ,lvar ,post-binding-lexenv)
     `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
                         ,post-binding-lexenv-p
                         (lambda (,ctran ,lvar ,post-binding-lexenv)