X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=6fd0661e1db9e621f2ba70f70bf765972be7a13a;hb=9cafc84b9f5a885d622db5909d5bc8e2b87f4cd5;hp=d8821958f863af85409eb3d3ab635a1e7f78dd0d;hpb=abf95924deb0b9677a160c02632749d80a3c24f8;p=sbcl.git

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index d882195..6fd0661 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -773,6 +773,7 @@
   (declare (type optional-dispatch res)
            (list default-vars default-vals entry-vars entry-vals vars body
                  aux-vars aux-vals))
+  (aver (or debug-name (neq '.anonymous. source-name)))
   (cond ((not vars)
          (if (optional-dispatch-keyp res)
              ;; Handle &KEY with no keys...
@@ -858,17 +859,17 @@
 ;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we
 ;;; figure out the MIN-ARGS and MAX-ARGS.
 (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals
-                                      &key
-                                      post-binding-lexenv
-                                      (source-name '.anonymous.)
-                                      (debug-name
-                                       (debug-name '&optional-dispatch vars)))
+                                 &key post-binding-lexenv
+                                 (source-name '.anonymous.)
+                                 debug-name)
   (declare (list body vars aux-vars aux-vals))
+  (aver (or debug-name (neq '.anonymous. source-name)))
   (let ((res (make-optional-dispatch :arglist vars
                                      :allowp allowp
                                      :keyp keyp
                                      :%source-name source-name
-                                     :%debug-name debug-name
+                                     :%debug-name (debug-name '&optional-dispatch
+                                                              (or debug-name source-name))
                                      :plist `(:ir1-environment
                                               (,*lexenv*
                                                ,*current-path*))))
@@ -899,7 +900,8 @@
     (compiler-error
      "The lambda expression has a missing or non-list lambda list:~%  ~S"
      form))
-
+  (unless (or debug-name (neq '.anonymous. source-name))
+    (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))
@@ -970,6 +972,8 @@
                                &key
                                (source-name '.anonymous.)
                                debug-name)
+  (when (and (not debug-name) (eq '.anonymous. source-name))
+    (setf debug-name (name-lambdalike thing)))
   (ecase (car thing)
     ((lambda)
      (ir1-convert-lambda thing
@@ -984,7 +988,7 @@
     ((named-lambda)
      (let ((name (cadr thing))
            (lambda-expression `(lambda ,@(cddr thing))))
-       (if (legal-fun-name-p name)
+       (if (and name (legal-fun-name-p name))
            (let ((defined-fun-res (get-defined-fun name))
                  (res (ir1-convert-lambda lambda-expression
                                           :maybe-add-debug-catch t
@@ -999,7 +1003,8 @@
              res)
            (ir1-convert-lambda lambda-expression
                                :maybe-add-debug-catch t
-                               :debug-name name))))
+                               :debug-name
+                               (or name (name-lambdalike thing))))))
     ((lambda-with-lexenv)
      (ir1-convert-inline-lambda thing
                                 :source-name source-name
@@ -1016,27 +1021,32 @@
                                   (source-name '.anonymous.)
                                   debug-name
                                   system-lambda)
+  (when (and (not debug-name) (eq '.anonymous. source-name))
+    (setf debug-name (name-lambdalike fun)))
   (destructuring-bind (decls macros symbol-macros &rest body)
-                      (if (eq (car fun) 'lambda-with-lexenv)
-                          (cdr fun)
-                          `(() () () . ,(cdr fun)))
-    (let ((*lexenv* (make-lexenv
-                     :default (process-decls decls nil nil
-                                             :lexenv (make-null-lexenv))
-                     :vars (copy-list symbol-macros)
-                     :funs (mapcar (lambda (x)
-                                     `(,(car x) .
-                                       (macro . ,(coerce (cdr x) 'function))))
-                                   macros)
-                     ;; Inherit MUFFLE-CONDITIONS from the call-site lexenv
-                     ;; rather than the definition-site lexenv, since it seems
-                     ;; like a much more common case.
-                     :handled-conditions (lexenv-handled-conditions *lexenv*)
-                     :policy (lexenv-policy *lexenv*)))
-          (*allow-instrumenting* (and (not system-lambda) *allow-instrumenting*)))
-      (ir1-convert-lambda `(lambda ,@body)
-                          :source-name source-name
-                          :debug-name debug-name))))
+      (if (eq (car fun) 'lambda-with-lexenv)
+          (cdr fun)
+          `(() () () . ,(cdr fun)))
+    (let* ((*lexenv* (make-lexenv
+                      :default (process-decls decls nil nil
+                                              :lexenv (make-null-lexenv))
+                      :vars (copy-list symbol-macros)
+                      :funs (mapcar (lambda (x)
+                                      `(,(car x) .
+                                         (macro . ,(coerce (cdr x) 'function))))
+                                    macros)
+                      ;; Inherit MUFFLE-CONDITIONS from the call-site lexenv
+                      ;; rather than the definition-site lexenv, since it seems
+                      ;; like a much more common case.
+                      :handled-conditions (lexenv-handled-conditions *lexenv*)
+                      :policy (lexenv-policy *lexenv*)))
+           (*allow-instrumenting* (and (not system-lambda)
+                                       *allow-instrumenting*))
+           (clambda (ir1-convert-lambda `(lambda ,@body)
+                                        :source-name source-name
+                                        :debug-name debug-name)))
+      (setf (functional-inline-expanded clambda) t)
+      clambda)))
 
 ;;; Get a DEFINED-FUN object for a function we are about to define. If
 ;;; the function has been forward referenced, then substitute for the