X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=5a40e8fd0383cb17b49fa5121cdf1c5c0ec62550;hb=5277a0cbf1a72243cad6808883a4847acefc8e6b;hp=41fd56869704b98aaf95f9dc30e8eeca39e72199;hpb=9ecb6b7686011c587bd0bf1b40a34c29338d89f3;p=sbcl.git

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 41fd568..5a40e8f 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -386,10 +386,6 @@
 	   ;; return its truename.
 	   (probe-init-files (&rest possible-init-file-names)
 	     (/show0 "entering PROBE-INIT-FILES")
-
-	     ;; REMOVEME: commented out while compiler has problems
-	     #+nil
-
 	     (prog1
 		 (find-if (lambda (x)
 			    (and (stringp x) (probe-file x)))
@@ -413,8 +409,6 @@
 						   'string
 						   user-home
 						   "/.sbclrc"))))
-	(/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME")
-
 
 	;; We wrap all the pre-REPL user/system customized startup code 
 	;; in a restart.
@@ -443,11 +437,14 @@
 		(eval eval)
 		(flush-standard-output-streams)))
 	  (continue ()
-		    :report "Continue anyway (skipping to toplevel read/eval/print loop)."
-		    (values)) ; (no-op, just fall through)
+	    :report
+	    "Continue anyway (skipping to toplevel read/eval/print loop)."
+	    (/show0 "CONTINUEing from pre-REPL RESTART-CASE")
+	    (values)) ; (no-op, just fall through)
 	  (quit ()
-		:report "Quit SBCL (calling #'QUIT, killing the process)."
-		(quit))))
+	    :report "Quit SBCL (calling #'QUIT, killing the process)."
+	    (/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
+	    (quit))))
 
       ;; one more time for good measure, in case we fell out of the
       ;; RESTART-CASE above before one of the flushes in the ordinary
@@ -455,7 +452,9 @@
       (flush-standard-output-streams)
 
       (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
-      (toplevel-repl noprint))))
+      (toplevel-repl noprint)
+      ;; (classic CMU CL error message: "You're certainly a clever child.":-)
+      (critically-unreachable "after TOPLEVEL-REPL"))))
 
 ;;; read-eval-print loop for the default system toplevel
 (defun toplevel-repl (noprint)
@@ -464,20 +463,30 @@
 	(- nil)
 	(+ nil) (++ nil) (+++ nil)
 	(/// nil) (// nil) (/ nil))
-    (/show0 "about to set up restarts in TOPLEVEL-REPL")
-    ;; There should only be one TOPLEVEL restart, and it's here, so
-    ;; restarting at TOPLEVEL always bounces you all the way out here.
-    (with-simple-restart (toplevel
-			  "Restart at toplevel READ/EVAL/PRINT loop.")
-      ;; We add a new ABORT restart for every debugger level, so 
-      ;; restarting at ABORT in a nested debugger gets you out to the
-      ;; innermost enclosing debugger, and only when you're in the
-      ;; outermost, unnested debugger level does restarting at ABORT 
-      ;; get you out to here.
-      (with-simple-restart (abort "Reduce debugger level (leaving debugger).")
-	(catch 'toplevel-catcher
-	  (sb!unix:unix-sigsetmask 0)	; FIXME: What is this for?
-	  (repl noprint))))))
+    ;; WITH-SIMPLE-RESTART doesn't actually restart its body as some
+    ;; (like WHN for an embarrassingly long time ca. 2001-12-07) might
+    ;; think, but instead drops control back out at the end. So when a
+    ;; TOPLEVEL or outermost-ABORT restart happens, we need this outer
+    ;; LOOP wrapper to grab control and start over again. (And it also
+    ;; wraps CATCH 'TOPLEVEL-CATCHER for similar reasons.)
+    (loop
+     (/show0 "about to set up restarts in TOPLEVEL-REPL")
+     ;; There should only be one TOPLEVEL restart, and it's here, so
+     ;; restarting at TOPLEVEL always bounces you all the way out here.
+     (with-simple-restart (toplevel
+			   "Restart at toplevel READ/EVAL/PRINT loop.")
+       ;; We add a new ABORT restart for every debugger level, so 
+       ;; restarting at ABORT in a nested debugger gets you out to the
+       ;; innermost enclosing debugger, and only when you're in the
+       ;; outermost, unnested debugger level does restarting at ABORT 
+       ;; get you out to here.
+       (with-simple-restart
+	   (abort
+	    "Reduce debugger level (leaving debugger, returning to toplevel).")
+	 (catch 'toplevel-catcher
+	   (sb!unix:unix-sigsetmask 0)	; FIXME: What is this for?
+	   (repl noprint)
+	   (critically-unreachable "after REPL")))))))
 
 (defun repl (noprint)
   (/show0 "entering REPL")
@@ -488,31 +497,28 @@
      ;; way we can convince the GC to just ignore dead areas of the
      ;; control stack, so that we don't need to rely on this
      ;; half-measure?
-     (/show0 "at head of LOOP")
      (scrub-control-stack)
-     (/show0 "back from SCRUB-CONTROL-STACK")
      (unless noprint
        (fresh-line)
-       (/show0 "back from FRESH-LINE")
        (princ (if (functionp *prompt*)
 		  (funcall *prompt*)
 		  *prompt*))
-       (/show0 "back from PRINC")
-       (flush-standard-output-streams)
-       (/show0 "back from FLUSH-STANDARD-OUTPUT-STREAMS"))
+       (flush-standard-output-streams))
      (let ((form (read *standard-input* nil eof-marker)))
-       (/show0 "back from READ")
-       (if (eq form eof-marker)
-	   (quit)
-	   (let ((results (multiple-value-list (interactive-eval form))))
-	     (unless noprint
-	       (dolist (result results)
-		 (fresh-line)
-		 (prin1 result)))))))))
+       (cond ((eq form eof-marker)
+	      (/show0 "doing QUIT for EOF in REPL")
+	      (quit))
+	     (t
+	      (let ((results (multiple-value-list (interactive-eval form))))
+		(unless noprint
+		  (dolist (result results)
+		    (fresh-line)
+		    (prin1 result))))))))))
 
 (defun noprogrammer-debugger-hook-fun (condition old-debugger-hook)
   (declare (ignore old-debugger-hook))
   (flet ((failure-quit (&key recklessly-p)
+           (/show0 "in FAILURE-QUIT (in noprogrammer debugger hook)")
 	   (quit :unix-status 1 :recklessly-p recklessly-p)))
     ;; This HANDLER-CASE is here mostly to stop output immediately
     ;; (and fall through to QUIT) when there's an I/O error. Thus,