X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=6bf18435ee1b80673d56a45581cce1eef070dff9;hb=2e5263a05f55e2b56a3194ad7853e9ae18ad69af;hp=33fd5fd7a30808a95da9bcd4e20ab809b4c49ca8;hpb=513f06e6c91af7a52c8c037d71386845b1c21a0f;p=sbcl.git

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 33fd5fd..6bf1843 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -1007,15 +1007,17 @@
                          :source-name source-name
                          :debug-name debug-name))
     ((instance-lambda)
-     (deprecation-warning 'instance-lambda 'lambda)
-     (ir1-convert-lambda `(lambda ,@(cdr thing))
+     (deprecation-warning :final "0.9.3.32" 'instance-lambda 'lambda)
+     (ir1-convert-lambda `(lambda (&rest args)
+                            (declare (ignore args))
+                            (deprecation-error "0.9.3.32" 'instance-lambda 'lambda))
                          :source-name source-name
                          :debug-name debug-name))
     ((named-lambda)
      (let ((name (cadr thing))
            (lambda-expression `(lambda ,@(cddr thing))))
        (if (and name (legal-fun-name-p name))
-           (let ((defined-fun-res (get-defined-fun name))
+           (let ((defined-fun-res (get-defined-fun name (second lambda-expression)))
                  (res (ir1-convert-lambda lambda-expression
                                           :maybe-add-debug-catch t
                                           :source-name name)))
@@ -1073,10 +1075,37 @@
       (setf (functional-inline-expanded clambda) t)
       clambda)))
 
+;;; Given a lambda-list, return a FUN-TYPE object representing the signature:
+;;; return type is *, and each individual arguments type is T -- but we get
+;;; the argument counts and keywords.
+(defun ftype-from-lambda-list (lambda-list)
+  (multiple-value-bind (req opt restp rest-name keyp key-list allowp morep)
+      (parse-lambda-list lambda-list)
+    (declare (ignore rest-name))
+    (flet ((t (list)
+             (mapcar (constantly t) list)))
+      (let ((reqs (t req))
+            (opts (when opt (cons '&optional (t opt))))
+            ;; When it comes to building a type, &REST means pretty much the
+            ;; same thing as &MORE.
+            (rest (when (or morep restp) (list '&rest t)))
+            (keys (when keyp
+                    (cons '&key (mapcar (lambda (spec)
+                                          (let ((key/var (if (consp spec)
+                                                             (car spec)
+                                                             spec)))
+                                            (list (if (consp key/var)
+                                                      (car key/var)
+                                                      (keywordicate key/var))
+                                                  t)))
+                                        key-list))))
+            (allow (when allowp (list '&allow-other-keys))))
+        (specifier-type `(function (,@reqs ,@opts ,@rest ,@keys ,@allow) *))))))
+
 ;;; Get a DEFINED-FUN object for a function we are about to define. If
 ;;; the function has been forward referenced, then substitute for the
 ;;; previous references.
-(defun get-defined-fun (name)
+(defun get-defined-fun (name &optional (lambda-list nil lp))
   (proclaim-as-fun-name name)
   (when (boundp '*free-funs*)
     (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
@@ -1087,15 +1116,20 @@
                     (res (make-defined-fun
                           :%source-name name
                           :where-from (if (eq where-from :declared)
-                                          :declared :defined)
-                          :type (leaf-type found))))
+                                          :declared
+                                          :defined-here)
+                          :type (if (eq :declared where-from)
+                                    (leaf-type found)
+                                    (if lp
+                                        (ftype-from-lambda-list lambda-list)
+                                        (specifier-type 'function))))))
                (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))
+             (get-defined-fun name lambda-list))
             (t found)))))
 
 ;;; Check a new global function definition for consistency with
@@ -1147,6 +1181,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
@@ -1163,7 +1218,9 @@
 (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
-      (setf defined-fun (get-defined-fun name))
+      (setf defined-fun (if lambda-with-lexenv
+                            (get-defined-fun name (fifth lambda-with-lexenv))
+                            (get-defined-fun name)))
       (when (boundp '*lexenv*)
         (remhash name *free-funs*)
         (aver (fasl-output-p *compile-object*))
@@ -1185,8 +1242,7 @@
     ;; old CMU CL comment:
     ;;   If there is a type from a previous definition, blast it,
     ;;   since it is obsolete.
-    (when (and defined-fun
-               (eq (leaf-where-from defined-fun) :defined))
+    (when (and defined-fun (neq :declared (leaf-where-from defined-fun)))
       (setf (leaf-type defined-fun)
             ;; FIXME: If this is a block compilation thing, shouldn't
             ;; we be setting the type to the full derived type for the