0.pre7.98:

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 5f12ea2..021a7bf 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -45,15 +45,15 @@
       (continuation-starts-block cont)
 
       (link-blocks start-block then-block)
-      (link-blocks start-block else-block)
+      (link-blocks start-block else-block))
 
-      (ir1-convert then-cont cont then)
-      (ir1-convert else-cont cont else))))
+    (ir1-convert then-cont cont then)
+    (ir1-convert else-cont cont else)))
 \f
 ;;;; BLOCK and TAGBODY
 
-;;;; We make an Entry node to mark the start and a :Entry cleanup to
-;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; We make an ENTRY node to mark the start and a :ENTRY cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an EXIT
 ;;;; node.
 
 ;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
@@ -85,16 +85,26 @@
       (ir1-convert-progn-body dummy cont forms))))
 
 
-;;; We make CONT start a block just so that it will have a block
-;;; assigned. People assume that when they pass a continuation into
-;;; IR1-CONVERT as CONT, it will have a block when it is done.
-(def-ir1-translator return-from ((name &optional value)
-                                start cont)
+(def-ir1-translator return-from ((name &optional value) start cont)
   #!+sb-doc
   "Return-From Block-Name Value-Form
   Evaluate the Value-Form, returning its values from the lexically enclosing
   BLOCK Block-Name. This is constrained to be used only within the dynamic
   extent of the BLOCK."
+  ;; CMU CL comment:
+  ;;   We make CONT start a block just so that it will have a block
+  ;;   assigned. People assume that when they pass a continuation into
+  ;;   IR1-CONVERT as CONT, it will have a block when it is done.
+  ;; KLUDGE: Note that this block is basically fictitious. In the code
+  ;;   (BLOCK B (RETURN-FROM B) (SETQ X 3))
+  ;; it's the block which answers the question "which block is
+  ;; the (SETQ X 3) in?" when the right answer is that (SETQ X 3) is
+  ;; dead code and so doesn't really have a block at all. The existence
+  ;; of this block, and that way that it doesn't explicitly say
+  ;; "I'm actually nowhere at all" makes some logic (e.g.
+  ;; BLOCK-HOME-LAMBDA-OR-NULL) more obscure, and it might be better
+  ;; to get rid of it, perhaps using a special placeholder value
+  ;; to indicate the orphanedness of the code.
   (continuation-starts-block cont)
   (let* ((found (or (lexenv-find name blocks)
                    (compiler-error "return for unknown block: ~S" name)))
@@ -106,6 +116,9 @@
     (setf (continuation-dest value-cont) exit)
     (ir1-convert start value-cont value)
     (prev-link exit value-cont)
+    (let ((home-lambda (continuation-home-lambda-or-null start)))
+      (when home-lambda
+       (push entry (lambda-calls-or-closes home-lambda))))
     (use-continuation exit (second found))))
 
 ;;; Return a list of the segments of a TAGBODY. Each segment looks
@@ -186,11 +199,15 @@
   is constrained to be used only within the dynamic extent of the TAGBODY."
   (continuation-starts-block cont)
   (let* ((found (or (lexenv-find tag tags :test #'eql)
-                   (compiler-error "Go to nonexistent tag: ~S." tag)))
+                   (compiler-error "attempt to GO to nonexistent tag: ~S"
+                                   tag)))
         (entry (first found))
         (exit (make-exit :entry entry)))
     (push exit (entry-exits entry))
     (prev-link exit start)
+    (let ((home-lambda (continuation-home-lambda-or-null start)))
+      (when home-lambda
+       (push entry (lambda-calls-or-closes home-lambda))))
     (use-continuation exit (second found))))
 \f
 ;;;; translators for compiler-magic special forms
@@ -442,7 +459,7 @@
 ;;; compiler. If the called function is a FUNCTION form, then convert
 ;;; directly to %FUNCALL, instead of waiting around for type
 ;;; inference.
-(def-source-transform funcall (function &rest args)
+(define-source-transform funcall (function &rest args)
   (if (and (consp function) (eq (car function) 'function))
       `(%funcall ,function ,@args)
       (values nil t)))
@@ -741,13 +758,16 @@
            (leaf
             (when (constant-p leaf)
               (compiler-error "~S is a constant and thus can't be set." name))
-            (when (and (lambda-var-p leaf)
-                       (lambda-var-ignorep leaf))
-              ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
-              ;; requires that this be a STYLE-WARNING, not a full warning.
-              (compiler-style-warning
-               "~S is being set even though it was declared to be ignored."
-               name))
+            (when (lambda-var-p leaf)
+              (let ((home-lambda (continuation-home-lambda-or-null start)))
+                (when home-lambda
+                  (pushnew leaf (lambda-calls-or-closes home-lambda))))
+              (when (lambda-var-ignorep leaf)
+                ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+                ;; requires that this be a STYLE-WARNING, not a full warning.
+                (compiler-style-warning
+                 "~S is being set even though it was declared to be ignored."
+                 name)))
             (set-variable start cont leaf (second things)))
            (cons
             (aver (eq (car leaf) 'MACRO))