From d36b416ae1fe7ba8a8d8e4ad7493458638028075 Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Sun, 27 Apr 2003 17:00:24 +0000 Subject: [PATCH] 0.pre8.112: - src/code/toplevel.lisp: Remove changes to REPL and rename REPL to REPL-FUN and add hook. - sb-aclrepl/tests.lisp: Add display tests. - sb-aclrepl/toplevel.lisp: New file. Toplevel REPL with support for catching signals - sb-aclrepl/README: state that sb-aclrepl must be loaded in ~/.sbclrc. --- contrib/sb-aclrepl/README | 7 +-- contrib/sb-aclrepl/debug.lisp | 78 ++++++++++++++++--------------- contrib/sb-aclrepl/inspect.lisp | 15 +++--- contrib/sb-aclrepl/repl.lisp | 53 ++++++++++++--------- contrib/sb-aclrepl/sb-aclrepl.asd | 3 +- contrib/sb-aclrepl/tests.lisp | 92 ++++++++++++++++++++----------------- src/code/toplevel.lisp | 65 +++++++++++--------------- version.lisp-expr | 2 +- 8 files changed, 163 insertions(+), 152 deletions(-) diff --git a/contrib/sb-aclrepl/README b/contrib/sb-aclrepl/README index 6eb65fd..a90a26c 100644 --- a/contrib/sb-aclrepl/README +++ b/contrib/sb-aclrepl/README @@ -7,11 +7,12 @@ debugger is planned. USAGE ===== -To start sb-aclrepl as your read-eval-print loop, execute the command +To start sb-aclrepl as your read-eval-print loop, you must +put the following command in your ~/.sbclrc. (require 'sb-aclrepl) -You can also all this command to your ~/.sbclrc to have sb-aclrepl be the default REPL -for your SBCL sessions. +The reason for this is that, currently, sb-aclrepl must loaded before +SBCL's default REPL starts. EXAMPLE ~/.sbclrc FILE ====================== diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 34b8db1..2b8787a 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -28,28 +28,31 @@ (throw 'debug-loop-catcher nil)))) (fresh-line) ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2) - (loop - (catch 'debug-loop-catcher - (handler-bind ((error (lambda (condition) - (when sb-debug::*flush-debug-errors* - (clear-input *debug-io*) - (princ condition) - ;; FIXME: Doing input on *DEBUG-IO* - ;; and output on T seems broken. - (format t - "~&error flushed (because ~ + (loop ;; only valid to way to exit invoke-debugger is by a restart + (catch 'debug-loop-catcher + (handler-bind ((error (lambda (condition) + (when sb-debug::*flush-debug-errors* + (clear-input *debug-io*) + (princ condition) + ;; FIXME: Doing input on *DEBUG-IO* + ;; and output on T seems broken. + (format t + "~&error flushed (because ~ ~S is set)" - 'sb-debug::*flush-debug-errors*) - (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) - ;; We have to bind LEVEL for the restart function created by - ;; WITH-SIMPLE-RESTART. - (let ((level sb-debug::*debug-command-level*) - (restart-commands (sb-debug::make-restart-commands))) - (with-simple-restart (abort - "~@" - level) - (sb-impl::repl :continuable continuable))))))))) + 'sb-debug::*flush-debug-errors*) + (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) + + (if (zerop *break-level*) ; restart added by SBCL + (repl :continuable continuable) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" + level) + (let ((sb-debug::*debug-restarts* (compute-restarts))) + (repl :continuable continuable))))))) + (throw 'repl-catcher (values :debug :exit)) + )))) (defun continuable-break-p () @@ -61,7 +64,15 @@ (when (boundp 'sb-debug::*debug-loop-fun*) (setq sb-debug::*debug-loop-fun* #'debug-loop)) -#|| +(defun print-restarts () + ;; (format *output* "~&Restart actions (select using :continue)~%") + (format *standard-output* "~&Restart actions (select using :continue)~%") + (let ((restarts (compute-restarts))) + (dotimes (i (length restarts)) + (format *standard-output* "~&~2D: ~A~%" i (nth i restarts))))) + + +#+ignore (defun debugger (condition) "Enter the debugger." (let ((old-hook *debugger-hook*)) @@ -74,18 +85,15 @@ (when (boundp 'sb-debug::*invoke-debugger-fun*) (setq sb-debug::*invoke-debugger-fun* #'debugger)) +#+ignore (defun print-condition (condition) (format *output* "~&Error: ~A~%" condition)) +#+ignore (defun print-condition-type (condition) (format *output* "~& [Condition type: ~A]~%" (type-of condition))) - -(defun print-restarts () - (format *output* "~&Restart actions (select using :continue)~%") - (let ((restarts (compute-restarts))) - (dotimes (i (length restarts)) - (format *output* "~&~2D: ~A~%" i (nth i restarts))))) - + +#+ignore (defun %debugger (condition) (print-condition condition) (print-condition-type condition) @@ -94,16 +102,14 @@ (acldebug-loop)) +#+ignore (defun acldebug-loop () (let ((continuable (continuable-break-p))) (if continuable (aclrepl :continuable t) - (let ((level sb-impl::*break-level*)) - (with-simple-restart (abort - "~@" - level) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" level) (loop - (sb-impl::repl))))))) - -||# + (repl))))))) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 22a4131..ebf484e 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -57,7 +57,7 @@ The commands are: (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))) -(defun inspector (object input-stream output-stream) +(defun inspector-fun (object input-stream output-stream) (declare (ignore input-stream)) (let ((*current-inspect* nil) (*inspect-raw* nil) @@ -69,11 +69,10 @@ The commands are: (redisplay output-stream) (let ((*input* input-stream) (*output* output-stream)) - (catch 'inspect-quit - (sb-impl::repl :inspect t))) - (values))) + (repl :inspect t))) + (values)) -(setq sb-impl::*inspect-fun* #'inspector) +(setq sb-impl::*inspect-fun* #'inspector-fun) (defun istep (args stream) (unless *current-inspect* @@ -161,11 +160,11 @@ The commands are: (no-object-msg stream)))) (defun istep-cmd-inspect-* (stream) - (reset-stack * "(inspect *") + (reset-stack * "(inspect *)") (redisplay stream)) (defun istep-cmd-inspect-new-form (form stream) - (inspector (eval form) nil stream)) + (inspector-fun (eval form) nil stream)) (defun istep-cmd-select-parent-component (option stream) (if (stack) @@ -203,7 +202,7 @@ The commands are: (defun istep-cmd-reset () (reset-stack) - (throw 'inspect-quit nil)) + (throw 'repl-catcher (values :inspect nil))) (defun istep-cmd-help (stream) (format stream *inspect-help*)) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index edfb513..ce1498c 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -7,10 +7,6 @@ ;;;; any given time, for this functionality is on the ACL website: ;;;; . -(cl:defpackage :sb-aclrepl - (:use :cl :sb-ext)) - - (cl:in-package :sb-aclrepl) (defstruct user-cmd @@ -31,7 +27,8 @@ (abbr-len 0)) ; abbreviation length (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *default-prompt* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~A(~D): " + (defparameter *default-prompt* + "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): " "The default prompt.")) (defparameter *prompt* #.*default-prompt* "The current prompt string or formatter function.") @@ -363,7 +360,7 @@ (values))) (defun inspect-cmd (arg) - (inspector arg nil *output*) + (inspector-fun arg nil *output*) (values)) (defun istep-cmd (&optional arg-string) @@ -437,9 +434,11 @@ (values)) (defun pop-cmd (&optional (n 1)) - ;; Find inspector - (when sb-impl::*inspect-break* - (throw 'inspect-quit nil)) + (cond + (*inspect-break* + (throw 'repl-catcher (values :inspect n))) + ((plusp *break-level*) + (throw 'repl-catcher (values :pop n)))) (values)) (defun bt-cmd (&optional (n most-positive-fixnum)) @@ -474,7 +473,7 @@ (defun continue-cmd (&optional (num 0)) ;; don't look at first restart - (let ((restarts (cdr (compute-restarts)))) + (let ((restarts (compute-restarts))) (if restarts (let ((restart (typecase num @@ -491,14 +490,18 @@ (string= (symbol-name sym1) (symbol-name sym2))))) (t - (format *output* "~S is invalid as a restart name.") + (format *output* "~S is invalid as a restart name" num) (return-from continue-cmd nil))))) (when restart (invoke-restart-interactively restart))) (format *output* "~&There are no restarts")))) (defun error-cmd () - (sb-debug::error-debug-command)) + (when (plusp *break-level*) + (if *inspect-break* + (sb-debug::show-restarts (compute-restarts) *output*) + (let ((sb-debug::*debug-restarts* (compute-restarts))) + (sb-debug::error-debug-command))))) (defun frame-cmd () (sb-debug::print-frame-call sb-debug::*current-frame*)) @@ -568,9 +571,8 @@ (values)) (defun reset-cmd () - #+ignore - (setf *break-stack* (last *break-stack*)) - (values)) + ;; The last restart goes to the toplevel + (invoke-restart-interactively (car (last (compute-restarts))))) (defun dirs-cmd () (dolist (dir *dir-stack*) @@ -720,8 +722,11 @@ (defun repl-prompt-fun (stream) - (let ((break-level (if (zerop sb-impl::*break-level*) - nil sb-impl::*break-level*))) + (let ((break-level (when (plusp *break-level*) + *break-level*)) + (frame-number (when (and (plusp *break-level*) + sb-debug::*current-frame*) + (sb-di::frame-number sb-debug::*current-frame*)))) #+sb-thread (let ((lock sb-thread::*session-lock*)) (sb-thread::get-foreground) @@ -730,14 +735,18 @@ (format stream "~{~&Thread ~A suspended~}~%" stopped-threads)))) (if (functionp *prompt*) (write-string (funcall *prompt* - sb-impl::*inspect-break* - sb-impl::*continuable-break* + break-level + frame-number + *inspect-break* + *continuable-break* (prompt-package-name) *cmd-number*) stream) (handler-case - (format nil *prompt* break-level - sb-impl::*inspect-break* - sb-impl::*continuable-break* + (format nil *prompt* + break-level + frame-number + *inspect-break* + *continuable-break* (prompt-package-name) *cmd-number*) (error () (format stream "~&Prompt error> ")) diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index c53f5c3..0c5b8f8 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -6,7 +6,8 @@ (defsystem sb-aclrepl :author "Kevin Rosenberg " :description "An AllegroCL compatible REPL" - :components ((:file "repl") + :components ((:file "toplevel") + (:file "repl" :depends-on ("toplevel")) (:file "inspect" :depends-on ("repl")) (:file "debug" :depends-on ("repl")))) diff --git a/contrib/sb-aclrepl/tests.lisp b/contrib/sb-aclrepl/tests.lisp index 10d40ae..ac725ed 100644 --- a/contrib/sb-aclrepl/tests.lisp +++ b/contrib/sb-aclrepl/tests.lisp @@ -356,25 +356,27 @@ tail-> a cyclic list with 1 element+tail") 1-> the symbol B tail-> a cyclic list with 2 elements+tail") -#| + ;;; Inspector traversal tests -(deftest inspect.0 (istep '(":i" "*simple-struct*")) - "# +(deftest inspect.0 (progn (setq * *simple-struct*) + (istep '("*"))) + "# 0 FIRST ----------> the symbol NIL 1 SLOT-2 ---------> the symbol A-VALUE 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") -(deftest istep.0 (prog1 - (progn (do-inspect *simple-struct*) (istep '("="))) - (reset-cmd)) - "# +(deftest istep.0 (progn (setq * *simple-struct*) + (istep '("*")) + (istep '("="))) + "# 0 FIRST ----------> the symbol NIL 1 SLOT-2 ---------> the symbol A-VALUE 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") -(deftest istep.1 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first"))) - (reset-cmd)) + +(deftest istep.1 (progn (setq * *simple-struct*) + (istep '("*")) + (istep '("first"))) "the symbol NIL 0 NAME -----------> a simple-string (3) \"NIL\" 1 PACKAGE --------> the COMMON-LISP package @@ -382,10 +384,11 @@ tail-> a cyclic list with 2 elements+tail") 3 FUNCTION -------> ..unbound.. 4 PLIST ----------> the symbol NIL") -(deftest istep.2 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">"))) - (reset-cmd)) + +(deftest istep.2 (progn (setq * *simple-struct*) + (istep '("*")) + (istep '("first")) + (istep '(">"))) "the symbol A-VALUE 0 NAME -----------> a simple-string (7) \"A-VALUE\" 1 PACKAGE --------> the ACLREPL-TESTS package @@ -393,10 +396,11 @@ tail-> a cyclic list with 2 elements+tail") 3 FUNCTION -------> ..unbound.. 4 PLIST ----------> the symbol NIL") -(deftest istep.3 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">")) (istep '("<"))) - (reset-cmd)) +(deftest istep.3 (progn (setq * *simple-struct*) + (istep '("*")) + (istep '("first")) + (istep '(">")) + (istep '("<"))) "the symbol NIL 0 NAME -----------> a simple-string (3) \"NIL\" 1 PACKAGE --------> the COMMON-LISP package @@ -404,44 +408,46 @@ tail-> a cyclic list with 2 elements+tail") 3 FUNCTION -------> ..unbound.. 4 PLIST ----------> the symbol NIL") -(deftest istep.4 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">")) (istep '("<")) (istep '("tree"))) - (reset-cmd)) +(deftest istep.4 (progn (setq * *simple-struct*) + (istep '("*")) + (istep '("first")) + (istep '(">")) + (istep '("<")) + (istep '("tree"))) "The current object is: the symbol NIL, which was selected by FIRST -#, which was selected by (inspect ...) +#, which was selected by (inspect *) ") -(deftest istep.5 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">")) (istep '("<")) (istep '("-"))) - (reset-cmd)) - "# +(deftest istep.5 (progn (setq * *simple-struct*) + (istep '("*")) + (istep '("first")) + (istep '(">")) + (istep '("<")) + (istep '("-"))) + "# 0 FIRST ----------> the symbol NIL 1 SLOT-2 ---------> the symbol A-VALUE 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") -(deftest istep.6 (prog1 - (progn (do-inspect *dotted-list*) (istep '("tail"))) - (reset-cmd)) +(deftest istep.6 (progn (setq * *dotted-list*) + (istep '("*")) + (istep '("tail"))) "fixnum 3") -(deftest istep.7 (prog1 - (progn (do-inspect *dotted-list*) (istep '("2"))) - (reset-cmd)) +(deftest istep.7 (progn (setq * *dotted-list*) + (istep '("*")) + (istep '("2"))) "fixnum 3") -(deftest istep.8 (prog1 (do-inspect 5.5d0) (reset-cmd)) - "double-float 5.5d0d") +(deftest istep.8 (progn (setq * 5.5d0) + (istep '("*"))) + "double-float 5.5d0") -(deftest istep.9 (prog1 (progn (do-inspect 5.5d0) (istep '("-"))) - (reset-cmd)) - "double-float 5.5d0d") +(deftest istep.9 (progn (setq * 5.5d0) + (istep '("-"))) + "Object has no parent +") -(deftest istep.10 (progn (do-inspect 5.5d0) (istep '("-")) - (istep '("q"))) - "No object is being inspected") -|# diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 3faf43e..d1df348 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -521,7 +521,7 @@ ;; have unwound enough stack by the time we get here that this ;; is now possible (sb!kernel::protect-control-stack-guard-page 1) - (repl :noprint noprint :break-level 0) + (funcall *repl-fun* noprint) (critically-unreachable "after REPL"))))))) ;;; Our default REPL prompt is the minimal traditional one. @@ -539,7 +539,6 @@ (quit) form))) - ;;; hooks to support customized toplevels like ACL-style toplevel ;;; from KMR on sbcl-devel 2002-12-21 (defvar *repl-read-form-fun* #'repl-read-form-fun @@ -551,42 +550,32 @@ (defvar *repl-prompt-fun* #'repl-prompt-fun "a function of one argument STREAM for the toplevel REPL to call: Prompt the user for input.") - -(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") - -(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)) - (/show0 "entering REPL") - (loop - ;; (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 (interactive-eval form)))) - (unless *noprint* - (dolist (result results) - (fresh-line) - (prin1 result))))))) +(defvar *repl-fun* #'repl-fun + "a function of one argument NOPRINT that provides the REPL for the system. + Assumes that *standard-input* and *standard-output* are setup.") + +(defun repl-fun (noprint) + (/show0 "entering REPL") + (loop + ;; (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 (interactive-eval form)))) + (unless noprint + (dolist (result results) + (fresh-line) + (prin1 result)))))) ;;; suitable value for *DEBUGGER-HOOK* for a noninteractive Unix-y program (defun noprogrammer-debugger-hook-fun (condition old-debugger-hook) diff --git a/version.lisp-expr b/version.lisp-expr index 39f7853..dd481f2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.111" +"0.pre8.112" -- 1.7.10.4