Changeset 5192


Ignore:
Timestamp:
12/19/03 03:24:02 (18 years ago)
Author:
piso
Message:

Work in progress.

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/debug.lisp

    r5162 r5192  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: debug.lisp,v 1.12 2003-12-16 14:37:57 piso Exp $
     4;;; $Id: debug.lisp,v 1.13 2003-12-19 03:24:02 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    1919
     20;;; Adapted from SBCL.
     21
    2022(in-package "EXTENSIONS")
    2123
    22 (export '(*debug-condition* *debug-level*))
     24(export '(*debug-condition* *debug-level* show-restarts))
    2325
    2426(defvar *debug-condition* nil)
     
    2830(in-package "SYSTEM")
    2931
     32(defun show-restarts (restarts stream)
     33  (when restarts
     34    (fresh-line stream)
     35    (format stream "Restarts:~%")
     36    (let ((max-name-len 0))
     37      (dolist (restart restarts)
     38        (let ((name (restart-name restart)))
     39          (when name
     40            (let ((len (length (princ-to-string name))))
     41              (when (> len max-name-len)
     42                (setf max-name-len len))))))
     43      (let ((count 0))
     44        (dolist (restart restarts)
     45          (let ((name (restart-name restart))
     46                (report-function (restart-report-function restart)))
     47            (%format stream "  ~D: ~A" count name)
     48            (when (functionp report-function)
     49              (dotimes (i (1+ (- max-name-len (length (princ-to-string name)))))
     50                (write-char #\space stream))
     51              (funcall report-function stream))
     52            (terpri stream))
     53          (incf count))))))
     54
    3055(defun debug-loop ()
    3156  (let ((*debug-level* (1+ *debug-level*)))
    32   (fresh-line *debug-io*)
    33   (%format *debug-io* "Type :CONTINUE to return from break or :RESET to return to top level.~%")
     57    (show-restarts (compute-restarts) *debug-io*)
    3458    (loop
    35       (catch 'debug-loop-catcher
    36         (handler-case
    37             (tpl::repl)
    38           (error (c) (%format t "Error: ~S.~%" c) (break) (throw 'debug-loop-catcher nil)))))))
     59      (tpl::repl))))
    3960
    4061(defun invoke-debugger (condition)
     
    4364          (*debugger-hook* nil))
    4465      (funcall hook-function condition hook-function)))
    45   (setf *debug-condition* condition)
    4666  (when condition
    4767    (fresh-line *debug-io*)
    4868    (%format *debug-io* "Debugger invoked on condition of type ~A:~%" (type-of condition))
    4969    (%format *debug-io* "  ~A~%" condition))
    50   (catch 'tpl::continue-catcher
     70  (let ((*debug-condition* condition)
     71        (level *debug-level*))
    5172    (clear-input)
    52     (debug-loop)))
     73    (if (> level 0)
     74        (with-simple-restart (abort "Return to debug level ~D." level)
     75          (debug-loop))
     76        (debug-loop))))
    5377
    54 (defun break (&optional format-control &rest format-arguments)
    55   (fresh-line *debug-io*)
    56   (%format *debug-io* "BREAK called.~%")
    57   (if format-control
    58       (apply #'%format *debug-io* format-control format-arguments))
    59   (invoke-debugger nil))
     78(defun break (&optional (format-control "BREAK called") &rest format-arguments)
     79  (with-simple-restart (continue "Return from BREAK.")
     80    (invoke-debugger
     81     (make-condition 'simple-condition
     82                     :format-control format-control
     83                     :format-arguments format-arguments)))
     84  nil)
  • trunk/j/src/org/armedbear/lisp/top-level.lisp

    r5162 r5192  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: top-level.lisp,v 1.21 2003-12-16 14:38:11 piso Exp $
     4;;; $Id: top-level.lisp,v 1.22 2003-12-19 03:23:38 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    4747  (loop
    4848    (let ((c (read-char stream nil)))
    49       (unless (eql c #\Space)
     49      (unless (eql c #\space)
    5050        (unread-char c stream)
    5151        (return c)))))
    52 
    53 (defun read-cmd (stream)
    54   (let ((c (peek-char-non-whitespace stream)))
    55     (if (eql c *command-char*)
    56         (read-line stream)
    57         (read stream nil))))
    5852
    5953(defun apropos-command (args)
     
    7165  (values))
    7266
    73 (defun continue-command (ignored)
    74   (if (> *debug-level* 0)
    75       (throw 'continue-catcher nil)))
     67(defun continue-command (args)
     68  (when args
     69    (let ((n (read-from-string args)))
     70      (let ((restarts (compute-restarts)))
     71        (when (< -1 n (length restarts))
     72          (invoke-restart (nth n restarts)))))))
    7673
    7774(defun describe-command (args)
    7875  (let ((obj (eval (read-from-string args))))
    7976    (describe obj)))
     77
     78(defun error-command (args)
     79  (when *debug-condition*
     80    (let* ((s (%format nil "~A" *debug-condition*))
     81           (len (length s)))
     82      (when (plusp len)
     83        (setf (schar s 0) (char-upcase (schar s 0)))
     84        (unless (eql (schar s (1- len)) #\.)
     85          (setf s (concatenate 'string s "."))))
     86      (format *debug-io* "~A~%" s))
     87    (show-restarts (compute-restarts) *debug-io*)))
    8088
    8189(defun inspect-command (args)
     
    106114
    107115(defun reset-command (ignored)
    108   (throw 'top-level-catcher nil))
     116  (invoke-restart 'top-level))
    109117
    110118(defun exit-command (ignored)
     
    168176    ("bt" 2 backtrace-command "backtrace n stack frames (default all)")
    169177    ("cd" 2 cd-command "change default directory")
    170     ("continue" 4 continue-command "return from break")
     178    ("continue" 4 continue-command "invoke restart n")
    171179    ("describe" 2 describe-command "describe an object")
     180    ("error" 3 error-command "print the current error message")
    172181    ("exit" 2 exit-command "exit lisp")
    173182    ("help" 2 help-command "print this help")
     
    206215
    207216(defun process-cmd (form)
    208   (when (and (stringp form) (> (length form) 1) (eql (char form 0) *command-char*))
    209     (let* ((pos (position #\Space form))
     217  (when (and (stringp form)
     218             (> (length form) 1)
     219             (eql (char form 0) *command-char*))
     220    (let* ((pos (position #\space form))
    210221           (cmd (subseq form 1 pos))
    211222           (args (if pos (subseq form (1+ pos)) nil)))
     
    221232  nil)
    222233
     234(defun read-cmd (stream)
     235  (let ((c (peek-char-non-whitespace stream)))
     236    (if (eql c *command-char*)
     237        (read-line stream)
     238        (read stream nil))))
     239
    223240(defun repl-read-form-fun (in out)
    224241  (loop
     
    229246             (funcall *repl-prompt-fun* *standard-output*)
    230247             (finish-output *standard-output*))
     248            ((and (> *debug-level* 0)
     249                  (fixnump form))
     250             (let ((n form)
     251                   (restarts (compute-restarts)))
     252               (if (< -1 n (length restarts))
     253                   (invoke-restart (nth n restarts))
     254                   (return form))))
    231255            (t
    232256             (return form))))))
     
    248272(defun top-level-loop ()
    249273  (fresh-line)
    250   (%format t "Type :HELP for a list of top-level commands.~%")
    251   (loop
    252     (catch 'top-level-catcher
    253       (handler-case
    254           (repl)
    255         #+j (stream-error (c) (return-from top-level-loop)) ; FIXME
    256         (error (c)
    257                (invoke-debugger c)
    258                (throw 'top-level-catcher nil))))))
     274  (%format t "Type :HELP for a list of available commands.~%")
     275  (loop
     276      (with-simple-restart (top-level
     277                            "Return to top level.")
     278        #+j
     279        (handler-case
     280            (repl)
     281          (stream-error (c) (return-from top-level-loop)))
     282        #-j
     283        (repl))))
Note: See TracChangeset for help on using the changeset viewer.