(cl:in-package :sb-aclrepl)
-(defun debugger (condition)
- "Enter the debugger."
- (let ((old-hook *debugger-hook*))
- (when old-hook
- (let ((*debugger-hook* nil))
- (funcall old-hook condition old-hook))))
- (%debugger condition))
-
-#+ignore
-(when (boundp 'sb-debug::*invoke-debugger-fun*)
- (setq sb-debug::*invoke-debugger-fun* #'debugger))
-
-(defun print-condition (condition)
- (format *output* "~&Error: ~A~%" condition))
-
-(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)))))
-
-(defun %debugger (condition)
- (print-condition condition)
- (print-condition-type condition)
- (princ #\newline *output*)
- (print-restarts)
- (debug-loop))
-
-(defun continuable-break-p ()
- (when (eq 'continue
- (restart-name (car (compute-restarts))))
- t))
-
(declaim (special
sb-debug::*debug-command-level sb-debug::*debug-command-level*
(sb-debug::*stack-top* (or sb-debug::*stack-top-hint*
sb-debug::*real-stack-top*))
(sb-debug::*stack-top-hint* nil)
- (sb-debug::*current-frame* sb-debug::*stack-top*))
+ (sb-debug::*current-frame* sb-debug::*stack-top*)
+ (continuable (continuable-break-p)))
(handler-bind ((sb-di:debug-condition
(lambda (condition)
(princ condition sb-debug::*debug-io*)
(sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil))))
(fresh-line)
- (sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
+ ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2)
(loop
(catch 'debug-loop-catcher
(handler-bind ((error (lambda (condition)
(with-simple-restart (abort
"~@<Reduce debugger level (to debug level ~W).~@:>"
level)
- (sb-debug::debug-prompt *debug-io*)
- (force-output *debug-io*)
- (let* ((exp (read *debug-io*))
- (cmd-fun (sb-debug::debug-command-p exp restart-commands)))
- (cond ((not cmd-fun)
- (sb-debug::debug-eval-print exp))
- ((consp cmd-fun)
- (format t "~&Your command, ~S, is ambiguous:~%"
- exp)
- (dolist (ele cmd-fun)
- (format t " ~A~%" ele)))
- (t
- (funcall cmd-fun))))))))))))
+ (sb-impl::repl :continuable continuable)))))))))
-#+ignore
-(defun debug-loop ()
- (let ((continuable (continuable-break-p)))
- (if continuable
- (aclrepl :continuable t)
- (with-simple-restart (abort
- "~@<Reduce debugger level (to debug level ~W).~@:>"
- *break-level*)
- (aclrepl)))))
+
+(defun continuable-break-p ()
+ (when (eq 'continue
+ (restart-name (car (compute-restarts))))
+ t))
#+ignore
(when (boundp 'sb-debug::*debug-loop-fun*)
(setq sb-debug::*debug-loop-fun* #'debug-loop))
+
+#||
+(defun debugger (condition)
+ "Enter the debugger."
+ (let ((old-hook *debugger-hook*))
+ (when old-hook
+ (let ((*debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
+ (%debugger condition))
+
+#+ignore
+(when (boundp 'sb-debug::*invoke-debugger-fun*)
+ (setq sb-debug::*invoke-debugger-fun* #'debugger))
+
+(defun print-condition (condition)
+ (format *output* "~&Error: ~A~%" condition))
+
+(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)))))
+
+(defun %debugger (condition)
+ (print-condition condition)
+ (print-condition-type condition)
+ (princ #\newline *output*)
+ (print-restarts)
+ (acldebug-loop))
+
+
+(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)
+ (loop
+ (sb-impl::repl)))))))
+
+||#
+
(setq *current-inspect* (make-inspect))
(reset-stack object "(inspect ...)")
(redisplay output-stream)
- (catch 'inspect-quit
- (aclrepl :inspect t))
+ (let ((*input* input-stream)
+ (*output* output-stream))
+ (catch 'inspect-quit
+ (sb-impl::repl :inspect t)))
(values)))
(setq sb-impl::*inspect-fun* #'inspector)
;;;; 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
(defparameter *cmd-number* 1
"Number of the next command")
+(defvar *input*)
+(defvar *output*)
+
(declaim (type list *history*))
(eval-when (:compile-toplevel :load-toplevel :execute)
(values))
(defun pop-cmd (&optional (n 1))
- #+ignore
- (let ((new-level (- (length *break-stack*) n 1)))
- (when (minusp new-level)
- (setq new-level 0))
- (dotimes (i (- (length *break-stack*) new-level 1))
- (pop *break-stack*)))
;; Find inspector
- #+ignore
- (do* ((i (1- (length *break-stack*)) (1- i))
- (found nil))
- ((or found (minusp i)))
- (let ((inspect (break-data-inspect (nth i *break-stack*))))
- (when inspect
- (set-current-inspect inspect)
- (setq found t))))
- (when *inspect-reason*
+ (when sb-impl::*inspect-break*
(throw 'inspect-quit nil))
(values))
-(defun continue-cmd (&optional (n 0))
- (let ((restarts (compute-restarts)))
+(defun bt-cmd (&optional (n most-positive-fixnum))
+ (sb-debug::backtrace n))
+
+(defun current-cmd ()
+ (sb-debug::describe-debug-command))
+
+(defun top-cmd ()
+ (sb-debug::frame-debug-command 0))
+
+(defun bottom-cmd ()
+ (sb-debug::bottom-debug-command))
+
+(defun up-cmd (&optional (n 1))
+ (dotimes (i n)
+ (if (and sb-debug::*current-frame*
+ (sb-di:frame-up sb-debug::*current-frame*))
+ (sb-debug::up-debug-command)
+ (progn
+ (format *output* "Top of the stack")
+ (return-from up-cmd)))))
+
+(defun dn-cmd (&optional (n 1))
+ (dotimes (i n)
+ (if (and sb-debug::*current-frame*
+ (sb-di:frame-down sb-debug::*current-frame*))
+ (sb-debug::down-debug-command)
+ (progn
+ (format *output* "Bottom of the stack")
+ (return-from dn-cmd)))))
+
+(defun continue-cmd (&optional (num 0))
+ ;; don't look at first restart
+ (let ((restarts (cdr (compute-restarts))))
(if restarts
- (if (< -1 n (length restarts))
- (invoke-restart-interactively (nth n restarts))
- (format *output* "~&There is no such restart"))
- (format *output* "~&There are no restarts"))))
+ (let ((restart
+ (typecase num
+ (unsigned-byte
+ (if (< -1 num (length restarts))
+ (nth num restarts)
+ (progn
+ (format *output* "There is no such restart")
+ (return-from continue-cmd))))
+ (symbol
+ (find num (the list restarts)
+ :key #'restart-name
+ :test (lambda (sym1 sym2)
+ (string= (symbol-name sym1)
+ (symbol-name sym2)))))
+ (t
+ (format *output* "~S is invalid as a restart name.")
+ (return-from continue-cmd nil)))))
+ (when restart
+ (invoke-restart-interactively restart)))
+ (format *output* "~&There are no restarts"))))
(defun error-cmd ()
- (print-restarts))
-
-(defun current-cmd ()
- )
+ (sb-debug::error-debug-command))
(defun frame-cmd ()
- )
+ (sb-debug::print-frame-call sb-debug::*current-frame*))
(defun zoom-cmd ()
)
(defun local-cmd (&optional var)
(declare (ignore var))
- )
+ (sb-debug::list-locals-debug-command))
(defun processes-cmd ()
#+sb-thread
(let ((cmd-table
'(("aliases" 3 alias-cmd "show aliases")
("apropos" 2 apropos-cmd "show apropos" :parsing :string)
+ ("bottom" 3 bottom-cmd "move to bottom stack frame")
+ ("top" 3 top-cmd "move to top stack frame")
+ ("bt" 2 bt-cmd "backtrace `n' stack frames, default all")
+ ("up" 2 up-cmd "move up `n' stack frames, default 1")
+ ("dn" 2 dn-cmd "move down `n' stack frames, default 1")
("cd" 2 cd-cmd "change default diretory" :parsing :string)
("ld" 2 ld-cmd "load a file" :parsing :string)
("cf" 2 cf-cmd "compile file" :parsing :string)
(defun repl-prompt-fun (stream)
- (let ((break-level
- (if (zerop *break-level*) nil *break-level*)))
+ (let ((break-level (if (zerop sb-impl::*break-level*)
+ nil sb-impl::*break-level*)))
#+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*
- *inspect-reason*
- *continuable-reason*
+ sb-impl::*inspect-break*
+ sb-impl::*continuable-break*
(prompt-package-name) *cmd-number*)
stream)
(handler-case
(format nil *prompt* break-level
- *inspect-reason*
- *continuable-reason*
+ sb-impl::*inspect-break*
+ sb-impl::*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 "toplevel")
- (:file "repl" :depends-on ("toplevel"))
+ :components ((:file "repl")
(:file "inspect" :depends-on ("repl"))
(:file "debug" :depends-on ("repl"))))
(defparameter *complex* #c(1 2))
(defparameter *ratio* 22/7)
(defparameter *double* 5.5d0)
+(defparameter *bignum* 1234567890123456789)
(defparameter *array* (make-array '(3 3 2) :initial-element nil))
(defparameter *vector* (make-array '(20):initial-contents
'(0 1 2 3 4 5 6 7 8 9
(def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag")))
(def-elements-tests *ratio* 2 #(22 7)
#((0 . "numerator") (1 . "denominator")))
+(def-elements-tests *bignum* 2
+ #(2112454933 287445236)
+ #((0 . :HEX32) (1 . :HEX32)))
(def-elements-tests *vector* 20
#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\""
nil 2)
+(def-display-test *bignum*
+"bignum 1234567890123456789 with 2 32-bit words
+ 0-> #x7DE98115
+ 1-> #x112210F4")
+
(def-display-test *vector*
"a simple T vector (20)
...
+++ /dev/null
-;;;; 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))
(*read-suppress* nil))
(unless (typep *debug-condition* 'step-condition)
(clear-input *debug-io*))
- (debug-loop)))
+ (funcall *debug-loop-fun*)))
\f
;;;; DEBUG-LOOP
"When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
executing in the debugger.")
-(defun debug-loop ()
+(defun debug-loop-fun ()
(let* ((*debug-command-level* (1+ *debug-command-level*))
(*real-stack-top* (sb!di:top-frame))
(*stack-top* (or *stack-top-hint* *real-stack-top*))
(t
(funcall cmd-fun))))))))))))
+(defvar *debug-loop-fun* #'debug-loop-fun
+ "a function taking no parameters that starts the low-level debug loop")
+
;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
(defun debug-eval-print (expr)
(/noshow "entering DEBUG-EVAL-PRINT" expr)
;; 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)
+ (repl :noprint noprint :break-level 0)
(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
"a function of one argument STREAM for the toplevel REPL to call: Prompt
the user for input.")
-(defun repl (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))))))
+(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)))))))
;;; 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.103"
+"0.pre8.104"
projects / sbcl.git / commitdiff