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

Work in progress.

File:
1 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)
Note: See TracChangeset for help on using the changeset viewer.