X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=b1ee7ee22260516686a85e02a9ce54f67f5633d4;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=b107a4197ee677c3e2fc10a5c566e9a54692e2f9;hpb=7c406887c08477181e869b1b98142d99b52990ac;p=sbcl.git

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index b107a41..b1ee7ee 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -33,9 +33,12 @@
     (compiler-error "The variable ~S occurs more than once in the lambda list."
                     name))
   (let ((kind (info :variable :kind name)))
-    (when (or (keywordp name) (eq kind :constant))
-      (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
-                      name))
+    (cond ((or (keywordp name) (eq kind :constant))
+           (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
+                           name))
+          ((eq :global kind)
+           (compiler-error "The name of the lambda variable ~S is already in use to name a global variable."
+                           name)))
     (cond ((eq kind :special)
            (let ((specvar (find-free-var name)))
              (make-lambda-var :%source-name name
@@ -916,7 +919,7 @@
     (setf debug-name (name-lambdalike form)))
   (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
       (make-lambda-vars (cadr form))
-    (multiple-value-bind (forms decls) (parse-body (cddr form))
+    (multiple-value-bind (forms decls doc) (parse-body (cddr form))
       (binding* (((*lexenv* result-type post-binding-lexenv)
                   (process-decls decls (append aux-vars vars) nil
                                  :binding-form-p t))
@@ -949,6 +952,7 @@
                                                       :system-lambda system-lambda)))))
         (setf (functional-inline-expansion res) form)
         (setf (functional-arg-documentation res) (cadr form))
+        (setf (functional-documentation res) doc)
         (when (boundp '*lambda-conversions*)
           ;; KLUDGE: Not counting TL-XEPs is a lie, of course, but
           ;; keeps things less confusing to users of TIME, where this
@@ -1074,24 +1078,25 @@
 ;;; previous references.
 (defun get-defined-fun (name)
   (proclaim-as-fun-name name)
-  (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
-    (note-name-defined name :function)
-    (cond ((not (defined-fun-p found))
-           (aver (not (info :function :inlinep name)))
-           (let* ((where-from (leaf-where-from found))
-                  (res (make-defined-fun
-                        :%source-name name
-                        :where-from (if (eq where-from :declared)
-                                        :declared :defined)
-                        :type (leaf-type found))))
-             (substitute-leaf res found)
-             (setf (gethash name *free-funs*) res)))
-          ;; If *FREE-FUNS* has a previously converted definition
-          ;; for this name, then blow it away and try again.
-          ((defined-fun-functionals found)
-           (remhash name *free-funs*)
-           (get-defined-fun name))
-          (t found))))
+  (when (boundp '*free-funs*)
+    (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
+      (note-name-defined name :function)
+      (cond ((not (defined-fun-p found))
+             (aver (not (info :function :inlinep name)))
+             (let* ((where-from (leaf-where-from found))
+                    (res (make-defined-fun
+                          :%source-name name
+                          :where-from (if (eq where-from :declared)
+                                          :declared :defined)
+                          :type (leaf-type found))))
+               (substitute-leaf res found)
+               (setf (gethash name *free-funs*) res)))
+            ;; If *FREE-FUNS* has a previously converted definition
+            ;; for this name, then blow it away and try again.
+            ((defined-fun-functionals found)
+             (remhash name *free-funs*)
+             (get-defined-fun name))
+            (t found)))))
 
 ;;; Check a new global function definition for consistency with
 ;;; previous declaration or definition, and assert argument/result
@@ -1142,6 +1147,27 @@
     (setf (functional-inlinep fun) inlinep)
     (assert-new-definition var fun)
     (setf (defined-fun-inline-expansion var) expansion)
+    ;; Associate VAR with the FUN -- and in case of an optional dispatch
+    ;; with the various entry-points. This allows XREF to know where the
+    ;; inline CLAMBDA comes from.
+    (flet ((note-inlining (f)
+             (typecase f
+               (functional
+                (setf (functional-inline-expanded f) var))
+               (cons
+                ;; Delayed entry-point.
+                (if (car f)
+                    (setf (functional-inline-expanded (cdr f)) var)
+                    (let ((old-thunk (cdr f)))
+                      (setf (cdr f) (lambda ()
+                                      (let ((g (funcall old-thunk)))
+                                        (setf (functional-inline-expanded g) var)
+                                        g)))))))))
+      (note-inlining fun)
+      (when (optional-dispatch-p fun)
+        (note-inlining (optional-dispatch-main-entry fun))
+        (note-inlining (optional-dispatch-more-entry fun))
+        (mapc #'note-inlining (optional-dispatch-entry-points fun))))
     ;; substitute for any old references
     (unless (or (not *block-compile*)
                 (and info
@@ -1158,14 +1184,13 @@
 (defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
   (let ((defined-fun nil)) ; will be set below if we're in the compiler
     (when compile-toplevel
-      ;; better be in the compiler
-      (aver (boundp '*lexenv*))
-      (remhash name *free-funs*)
       (setf defined-fun (get-defined-fun name))
-      (aver (fasl-output-p *compile-object*))
-      (if (member name *fun-names-in-this-file* :test #'equal)
-          (warn 'duplicate-definition :name name)
-          (push name *fun-names-in-this-file*)))
+      (when (boundp '*lexenv*)
+        (remhash name *free-funs*)
+        (aver (fasl-output-p *compile-object*))
+        (if (member name *fun-names-in-this-file* :test #'equal)
+            (warn 'duplicate-definition :name name)
+            (push name *fun-names-in-this-file*))))
 
     (become-defined-fun-name name)