X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Ftoplevel.lisp;h=e80ad9b67277f36c911f11a40190da04fe0c5699;hb=6a71280af32d6bb02ed07d1a576df2cd9c5dfb79;hp=c0a4d4e3bcbeb5b244050362e91b77987f419a40;hpb=3e991f3ecd3a0a5ba50bc5b43c4ed0133c837701;p=sbcl.git diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp index c0a4d4e..e80ad9b 100644 --- a/contrib/sb-aclrepl/toplevel.lisp +++ b/contrib/sb-aclrepl/toplevel.lisp @@ -1,80 +1,80 @@ -;;;; Toplevel for sb-aclrepl - (cl:defpackage :sb-aclrepl - (:use :cl :sb-ext)) + (:use "COMMON-LISP" "SB-EXT") + (:shadowing-import-from "SB-IMPL" "SCRUB-CONTROL-STACK") + (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*") + (:export + ;; user-level customization of UI + "*PROMPT*" "*EXIT-ON-EOF*" "*MAX-HISTORY*" + "*USE-SHORT-PACKAGE-NAME*" "*COMMAND-CHAR*" + ;; user-level customization of functionality + "ALIAS" + ;; internalsish, but the documented way to make a new repl "object" + ;; such that it inherits the current state of the repl but has its + ;; own independent state subsequently. + "MAKE-REPL-FUN")) (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*))))))) - +(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") -;;; 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.) +(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 - ;; 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 - "~@") - (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"))))))) + (multiple-value-bind (reason reason-param) + (catch 'repl-catcher + (loop + (unwind-protect + (rep-one) + ;; if we started stepping in the debugger, now is the + ;; time to stop + (sb-impl::disable-stepping)))) + (declare (ignore reason-param)) + (cond + ((and (eq reason :inspect) + (plusp *break-level*)) + (return-from repl)) + ((and (eq reason :pop) + (plusp *break-level*)) + (return-from repl))))))) -#+ignore -(when (boundp 'sb-impl::*toplevel-repl-fun*) - (setq sb-impl::*toplevel-repl-fun* #'toplevel-aclrepl-fun)) +(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) + ;; FIXME: Calling fresh-line before a result ensures the result starts + ;; on a newline, but it usually generates an empty line. + ;; One solution would be to have the newline's entered on the + ;; input stream inform the output stream that the column should be + ;; reset to the beginning of the line. + (fresh-line *standard-output*) + (prin1 result *standard-output*)))))