+;;;; 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")
+
+(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))
+ (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*)))))))
+
+
+;;; 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")))))))
+
+#+ignore
+(when (boundp 'sb-impl::*toplevel-repl-fun*)
+ (setq sb-impl::*toplevel-repl-fun* #'toplevel-aclrepl-fun))