X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=7d05f20787a3c306262776f51e40842ac38ad3e3;hb=f7faed97898dd0e94a18b0d1fca03aaa0fe24ab0;hp=94094825ea093629252a3a04ffedad5096a61f1d;hpb=a7a4ca961ef0f587a2549bd9433eef7ddb845ab7;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 9409482..7d05f20 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -476,15 +476,37 @@ body, references to a NAME will effectively be replaced with the EXPANSION."
 Return VALUE without evaluating it."
   (reference-constant start next result thing))
 
+(defun name-context ()
+  ;; Name of the outermost non-NIL BLOCK, or the source namestring
+  ;; of the source file.
+  (let ((context
+          (or (car (find-if (lambda (b)
+                              (let ((name (pop b)))
+                                (and name
+                                     ;; KLUDGE: High debug adds this block on
+                                     ;; some platforms.
+                                     #!-unwind-to-frame-and-call-vop
+                                     (neq 'return-value-tag name)
+                                     ;; KLUDGE: CATCH produces blocks whose
+                                     ;; cleanup is :CATCH.
+                                     (neq :catch (cleanup-kind (entry-cleanup (pop b)))))))
+                            (lexenv-blocks *lexenv*) :from-end t))
+              *source-namestring*
+              (let ((p (or *compile-file-truename* *load-truename*)))
+                (when p (namestring p))))))
+    (when context
+      (list :in context))))
+
 ;;;; FUNCTION and NAMED-LAMBDA
 (defun name-lambdalike (thing)
   (case (car thing)
     ((named-lambda)
      (or (second thing)
-         `(lambda ,(third thing))))
+         `(lambda ,(third thing) ,(name-context))))
     ((lambda)
-     `(lambda ,(second thing)))
+     `(lambda ,(second thing) ,@(name-context)))
     ((lambda-with-lexenv)
+     ;; FIXME: Get the original DEFUN name here.
      `(lambda ,(fifth thing)))
     (otherwise
      (compiler-error "Not a valid lambda expression:~%  ~S"
@@ -814,10 +836,11 @@ lexically apparent function definition in the enclosing environment."
     (multiple-value-bind (names defs)
         (extract-flet-vars definitions 'flet)
       (let ((fvars (mapcar (lambda (n d)
-                             (ir1-convert-lambda d
-                                                 :source-name n
-                                                 :maybe-add-debug-catch t
-                                                 :debug-name (debug-name 'flet n)))
+                             (ir1-convert-lambda
+                              d :source-name n
+                                :maybe-add-debug-catch t
+                                :debug-name
+                                (debug-name 'flet n t)))
                            names defs)))
         (processing-decls (decls nil fvars next result)
           (let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
@@ -852,7 +875,7 @@ other."
                           (ir1-convert-lambda def
                                               :source-name name
                                               :maybe-add-debug-catch t
-                                              :debug-name (debug-name 'labels name)))
+                                              :debug-name (debug-name 'labels name t)))
                         names defs))))
 
         ;; Modify all the references to the dummy function leaves so
@@ -994,7 +1017,8 @@ care."
         (dest-lvar (make-lvar))
         (type (or (lexenv-find var type-restrictions)
                   (leaf-type var))))
-    (ir1-convert start dest-ctran dest-lvar `(the ,type ,value))
+    (ir1-convert start dest-ctran dest-lvar `(the ,(type-specifier type)
+                                                  ,value))
     (let ((res (make-set :var var :value dest-lvar)))
       (setf (lvar-dest dest-lvar) res)
       (setf (leaf-ever-used var) t)