From: Kevin Rosenberg Date: Fri, 25 Apr 2003 16:31:17 +0000 (+0000) Subject: 0.pre8.104: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f06a378c741965a906b6a042c9420efb9c51198f;p=sbcl.git 0.pre8.104: * src/code/toplevel.lisp: Add special variables to convert SB-IMPL::REPL into a recursively invokable funcion * src/code/debug.lisp: Add hook for SB-DEBUG::DEBUG-LOOP * contrib/sb-aclrepl/tests.lisp: add tests for bignum inspection * contrib/sb-aclrepl/repl.lisp: convert to use new SB-IMPL::REPL function, add some debugger commands * contrib/sb-aclrepl/debug.lisp: use SB-DEBUG::*DEBUG-LOOP-FUN* hook. however, hook is not yet enabled by default while debugger function continues development. --- diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 250200b..34b8db1 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -6,42 +6,6 @@ (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* @@ -55,14 +19,15 @@ (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) @@ -84,30 +49,61 @@ (with-simple-restart (abort "~@" 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 - "~@" - *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 + "~@" + level) + (loop + (sb-impl::repl))))))) + +||# + diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index ff59745..22a4131 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -67,8 +67,10 @@ The commands are: (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) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 69b6314..edfb513 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -7,6 +7,10 @@ ;;;; 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 @@ -46,6 +50,9 @@ (defparameter *cmd-number* 1 "Number of the next command") +(defvar *input*) +(defvar *output*) + (declaim (type list *history*)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -430,48 +437,78 @@ (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 @@ -546,6 +583,11 @@ (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) @@ -678,8 +720,8 @@ (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) @@ -688,14 +730,14 @@ (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> ")) diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index 0c5b8f8..c53f5c3 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -6,8 +6,7 @@ (defsystem sb-aclrepl :author "Kevin Rosenberg " :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")))) diff --git a/contrib/sb-aclrepl/tests.lisp b/contrib/sb-aclrepl/tests.lisp index 85d2f9e..10d40ae 100644 --- a/contrib/sb-aclrepl/tests.lisp +++ b/contrib/sb-aclrepl/tests.lisp @@ -52,6 +52,7 @@ (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 @@ -186,6 +187,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)) @@ -311,6 +315,11 @@ 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) ... diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp deleted file mode 100644 index c0a4d4e..0000000 --- a/contrib/sb-aclrepl/toplevel.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;;; 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 - "~@") - (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)) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 20fa0da..927ba88 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -825,7 +825,7 @@ reset to ~S." (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - (debug-loop))) + (funcall *debug-loop-fun*))) ;;;; DEBUG-LOOP @@ -836,7 +836,7 @@ reset to ~S." "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*)) @@ -884,6 +884,9 @@ reset to ~S." (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) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index c05f092..3faf43e 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) + (repl :noprint noprint :break-level 0) (critically-unreachable "after REPL"))))))) ;;; Our default REPL prompt is the minimal traditional one. @@ -539,6 +539,7 @@ (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,28 +552,41 @@ "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) diff --git a/version.lisp-expr b/version.lisp-expr index 734b445..b2ac7fc 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.103" +"0.pre8.104"