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
======================
(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
- "~@<Reduce debugger level (to debug level ~W).~@:>"
- 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 "~@<Reduce debugger level (to break level ~W).~@:>"
+ level)
+ (let ((sb-debug::*debug-restarts* (compute-restarts)))
+ (repl :continuable continuable)))))))
+ (throw 'repl-catcher (values :debug :exit))
+ ))))
(defun continuable-break-p ()
(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*))
(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)
(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
- "~@<Reduce debugger level (to debug level ~W).~@:>"
- level)
+ (let ((level *break-level*))
+ (with-simple-restart
+ (abort "~@<Reduce debugger level (to debug level ~W).~@:>" level)
(loop
- (sb-impl::repl)))))))
-
-||#
+ (repl)))))))
(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)
(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*
(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)
(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*))
;;;; any given time, for this functionality is on the ACL website:
;;;; <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>.
-(cl:defpackage :sb-aclrepl
- (:use :cl :sb-ext))
-
-
(cl:in-package :sb-aclrepl)
(defstruct user-cmd
(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.")
(values)))
(defun inspect-cmd (arg)
- (inspector arg nil *output*)
+ (inspector-fun arg nil *output*)
(values))
(defun istep-cmd (&optional arg-string)
(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))
(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
(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*))
(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*)
(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)
(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> "))
(defsystem sb-aclrepl
:author "Kevin Rosenberg <kevin@rosenberg.net>"
: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"))))
1-> the symbol B
tail-> a cyclic list with 2 elements+tail")
-#|
+
;;; Inspector traversal tests
-(deftest inspect.0 (istep '(":i" "*simple-struct*"))
- "#<STRUCTURE-CLASS SIMPLE-STRUCT>
+(deftest inspect.0 (progn (setq * *simple-struct*)
+ (istep '("*")))
+ "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
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))
- "#<STRUCTURE-CLASS SIMPLE-STRUCT>
+(deftest istep.0 (progn (setq * *simple-struct*)
+ (istep '("*"))
+ (istep '("=")))
+ "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
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
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
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
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
-#<STRUCTURE-CLASS SIMPLE-STRUCT>, which was selected by (inspect ...)
+#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>, which was selected by (inspect *)
")
-(deftest istep.5 (prog1
- (progn (do-inspect *simple-struct*) (istep '("first"))
- (istep '(">")) (istep '("<")) (istep '("-")))
- (reset-cmd))
- "#<STRUCTURE-CLASS SIMPLE-STRUCT>
+(deftest istep.5 (progn (setq * *simple-struct*)
+ (istep '("*"))
+ (istep '("first"))
+ (istep '(">"))
+ (istep '("<"))
+ (istep '("-")))
+ "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
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")
-|#
;; 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.
(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
(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)
;;; 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"
projects / sbcl.git / commitdiff