From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Sat, 11 Jan 2003 17:52:35 +0000 (+0000)
Subject: 0.7.11.7:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9ce73d3eeef7ed9dda2f8029c5f42cc17798ad51;p=sbcl.git

0.7.11.7:
	Fix for averrance failure due to DEBUG-RETURN interfering with
		type system (explanation APD sbcl-devel 2003-01-10)
	... disable insertion of CATCH if it was disabled in an outer
		LAMBDA;
	... enable insertion of CATCH when compiling top-level forms, so
		that the evaluator continues to have DEBUG-RETURN
		goodness.
---

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index aa346d4..e6f917f 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -48,6 +48,11 @@
   to optimize code which uses those definitions? Setting this true
   gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
   the efficiency of stable code.")
+
+;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
+;;; insertion a (CATCH ...) around code to allow the debugger RETURN
+;;; command to function.
+(defvar *allow-debug-catch-tag* t)
 
 ;;;; namespace management utilities
 
@@ -1960,33 +1965,34 @@
      "The lambda expression has a missing or non-list lambda list:~%  ~S"
      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))
-      (let* ((result-cont (make-continuation))
-	     (*lexenv* (process-decls decls
-				      (append aux-vars vars)
-				      nil result-cont))
-	     (forms (if (and allow-debug-catch-tag
-			     (policy *lexenv* (> debug (max speed space))))
-			`((catch (make-symbol "SB-DEBUG-CATCH-TAG")
-			    ,@forms))
-			forms))
-	     (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
-		      (ir1-convert-hairy-lambda forms vars keyp
-						allow-other-keys
-						aux-vars aux-vals result-cont
-						:source-name source-name
-						:debug-name debug-name)
-		      (ir1-convert-lambda-body forms vars
-					       :aux-vars aux-vars
-					       :aux-vals aux-vals
-					       :result result-cont
-					       :source-name source-name
-					       :debug-name debug-name))))
-	(setf (functional-inline-expansion res) form)
-	(setf (functional-arg-documentation res) (cadr form))
-	res))))
+  (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
+    (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))
+	(let* ((result-cont (make-continuation))
+	       (*lexenv* (process-decls decls
+					(append aux-vars vars)
+					nil result-cont))
+	       (forms (if (and *allow-debug-catch-tag*
+			       (policy *lexenv* (> debug (max speed space))))
+			  `((catch (make-symbol "SB-DEBUG-CATCH-TAG")
+			      ,@forms))
+			  forms))
+	       (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+			(ir1-convert-hairy-lambda forms vars keyp
+						  allow-other-keys
+						  aux-vars aux-vals result-cont
+						  :source-name source-name
+						  :debug-name debug-name)
+			(ir1-convert-lambda-body forms vars
+						 :aux-vars aux-vars
+						 :aux-vals aux-vals
+						 :result result-cont
+						 :source-name source-name
+						 :debug-name debug-name))))
+	  (setf (functional-inline-expansion res) form)
+	  (setf (functional-arg-documentation res) (cadr form))
+	  res)))))
 
 ;;;; defining global functions
 
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 6b3debf..e8e62a6 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -874,7 +874,11 @@
     (let* ((locall-fun (ir1-convert-lambda
                         definition
                         :debug-name (debug-namify "top level local call ~S"
-                                                  name)))
+                                                  name)
+			;; KLUDGE: we do this so that we get to have
+			;; nice debug returnness in functions defined
+			;; from the REPL
+			:allow-debug-catch-tag t))
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
 				    :source-name (or name '.anonymous.)
 				    :debug-name (unless name
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 46f15ef..dbb2420 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -728,6 +728,29 @@ BUG 48c, not yet fixed:
   (coerce x '(values t)))
 (assert (null (ignore-errors (coerce-defopt 3))))
 
+;;; Oops.  In part of the (CATCH ..) implementation of DEBUG-RETURN,
+;;; it was possible to confuse the type deriver of the compiler
+;;; sufficiently that compiler invariants were broken (explained by
+;;; APD sbcl-devel 2003-01-11).
+
+;;; WHN's original report
+(defun debug-return-catch-break1 ()
+  (with-open-file (s "/tmp/foo"
+		     :direction :output
+		     :element-type (list
+				    'signed-byte
+				    (1+
+				     (integer-length most-positive-fixnum))))
+    (read-byte s)
+    (read-byte s)
+    (read-byte s)
+    (read-byte s)))
+
+;;; APD's simplified test case
+(defun debug-return-catch-break2 (x)
+  (declare (type (vector (unsigned-byte 8)) x))
+  (setq *y* (the (unsigned-byte 8) (aref x 4))))
+
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
 
diff --git a/version.lisp-expr b/version.lisp-expr
index fd08eaf..85487d7 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.11.6"
+"0.7.11.7"