X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Ftoplevel.lisp;h=cdcc09b7b5d452cec85a631e1070bf873ac88524;hb=e8f691fc1ba5e3aebc74fd8723c7cc550a4f1e35;hp=c0a4d4e3bcbeb5b244050362e91b77987f419a40;hpb=3e991f3ecd3a0a5ba50bc5b43c4ed0133c837701;p=sbcl.git

diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp
index c0a4d4e..cdcc09b 100644
--- a/contrib/sb-aclrepl/toplevel.lisp
+++ b/contrib/sb-aclrepl/toplevel.lisp
@@ -1,80 +1,67 @@
-;;;; Toplevel for sb-aclrepl
-
 (cl:defpackage :sb-aclrepl
   (:use :cl :sb-ext))
 
 (cl:in-package :sb-aclrepl)
 
-(defvar *break-level* 0 "Current break level")
-(defvar *inspect-reason* nil
-  "Boolean if break level was started for inspecting.")
-(defvar *continuable-reason* nil
-  "Boolean if break level was started by continuable error.")
-(defvar *noprint* nil "Boolean is output should be displayed")
-(defvar *input* nil "Input stream")
-(defvar *output* nil "Output stream")
+(defvar *noprint* nil "boolean: T if don't print prompt and output")
+(defvar *break-level* 0 "current break level")
+(defvar *inspect-break* nil "boolean: T if break caused by inspect")
+(defvar *continuable-break* nil "boolean: T if break caused by continuable error")
+
+(shadowing-import '(sb-impl::scrub-control-stack
+		    sb-int:*repl-prompt-fun* sb-int:*repl-read-form-fun*)
+		  :sb-aclrepl)
+	  
 
-(defun aclrepl (&key
-		(break-level (1+ *break-level*))
-		;; Break level is started to inspect an object
-		inspect
-		;; Signals a continuable error
-		continuable)
-  (let ((*break-level* break-level)
-	(*inspect-reason* inspect)
-	(*continuable-reason* continuable))
+(defun repl (&key
+	     (break-level (1+ *break-level*))
+	     (noprint *noprint*)
+	     (inspect nil)
+	     (continuable nil))
+  (let ((*noprint* noprint)
+	(*break-level* break-level)
+	(*inspect-break* inspect)
+	(*continuable-break* continuable))
+    (sb-int:/show0 "entering REPL")
     (loop
-     ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
-     (sb-impl::scrub-control-stack)
-     (unless *noprint*
-       (funcall (the function sb-int:*repl-prompt-fun*) *output*)
-       (force-output *output*))
-     (let* ((form (funcall (the function sb-int:*repl-read-form-fun*)
-			   *input* *output*))
-	    (results (multiple-value-list (interactive-eval form))))
-       (unless *noprint*
-	 (dolist (result results)
-	   (fresh-line *output*)
-	   (prin1 result *output*)))))))
+     (multiple-value-bind (reason reason-param)
+	 (catch 'repl-catcher
+	   (loop
+	    (rep-one)))
+       (cond
+	 ((and (eq reason :inspect)
+	       (plusp *break-level*))
+	  (return-from repl))
+	 ((and (eq reason :pop)
+	       (plusp *break-level*))
+	  (return-from repl)))))))
 
+(defun rep-one ()
+  "Read-Eval-Print one form"
+  ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
+  (scrub-control-stack)
+  (unless *noprint*
+    (funcall *repl-prompt-fun* *standard-output*)
+    ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
+    ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
+    ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
+    ;; odd. But maybe there *is* a valid reason in some
+    ;; circumstances? perhaps some deadlock issue when being driven
+    ;; by another process or something...)
+    (force-output *standard-output*))
+  (let* ((form (funcall *repl-read-form-fun*
+			*standard-input*
+			*standard-output*))
+	 (results (multiple-value-list (sb-impl::interactive-eval form))))
+    (unless *noprint*
+      (dolist (result results)
+	;; Don't fresh-line before a result, since newline was entered by user
+	;; in *repl-read-form-fun*
+	(fresh-line *standard-output*)
+	(prin1 result *standard-output*)))))
 
-;;; read-eval-print loop for the default system toplevel
-(defun toplevel-aclrepl-fun (noprint)
-  (let ((* nil) (** nil) (*** nil)
-	(- nil)
-	(+ nil) (++ nil) (+++ nil)
-	(/// nil) (// nil) (/ nil))
-    ;; 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
-     ;; 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
-	   #-sunos (sb-unix:unix-sigsetmask 0)	; FIXME: What is this for?
-	   ;; in the event of a control-stack-exhausted-error, we should
-	   ;; have unwound enough stack by the time we get here that this
-	   ;; is now possible
-	   (sb-kernel::protect-control-stack-guard-page 1)
-	   (let ((*noprint* noprint)
-		 (*input* *standard-input*)
-		 (*output* *standard-output*))
-	     (aclrepl :break-level 0))
-	   (sb-impl::critically-unreachable "after REPL")))))))
+(defun repl-fun (noprint)
+  (repl :noprint noprint :break-level 0))
 
-#+ignore
-(when (boundp 'sb-impl::*toplevel-repl-fun*)
-  (setq sb-impl::*toplevel-repl-fun* #'toplevel-aclrepl-fun))
+(when (boundp 'sb-impl::*repl-fun*)
+  (setq sb-impl::*repl-fun* #'repl-fun))