X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=021a7bf57b3d4eed851eb12b27d47322face78fd;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=b8f657c8abddb5e406951d6f70ab080e7a305f4d;hpb=984fdfe0dd7c0acfb915b11f7dba86ff3713778f;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index b8f657c..021a7bf 100644
--- 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)))
 
 ;;;; 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))))
 
 ;;;; 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))
@@ -789,7 +809,7 @@
 	       `(multiple-value-call #'%throw ,tag ,result)))
 
 ;;; This is a special special form used to instantiate a cleanup as
-;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; the current cleanup within the body. KIND is the kind of cleanup
 ;;; to make, and MESS-UP is a form that does the mess-up action. We
 ;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
 ;;; and introduce the cleanup into the lexical environment. We
@@ -853,11 +873,11 @@
 	    (%catch (%escape-function ,exit-block) ,tag)
 	  ,@body)))))
 
-;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the
 ;;; cleanup forms into a local function so that they can be referenced
 ;;; both in the case where we are unwound and in any local exits. We
 ;;; use %CLEANUP-FUNCTION on this to indicate that reference by
-;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
+;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of
 ;;; an XEP.
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc