Changeset 8502


Ignore:
Timestamp:
02/08/05 02:41:45 (17 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/restart.lisp

    r8423 r8502  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: restart.lisp,v 1.18 2005-01-31 17:17:30 piso Exp $
     4;;; $Id: restart.lisp,v 1.19 2005-02-08 02:41:45 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    8787        (return-from find-restart restart)))))
    8888
     89(defun find-restart-or-control-error (identifier &optional condition)
     90  (or (find-restart identifier condition)
     91      (error 'control-error
     92       :format-control "Restart ~S is not active."
     93       :format-arguments (list identifier))))
     94
    8995(defun invoke-restart (restart &rest values)
    90   (let ((real-restart (or (find-restart restart)
    91                           (error 'control-error
    92                                  :format-control "Restart ~s is not active."
    93                                  :format-arguments (list restart)))))
     96  (let ((real-restart (find-restart-or-control-error restart)))
    9497    (apply (restart-function real-restart) values)))
    9598
     
    235238
    236239(defun abort (&optional condition)
    237   (invoke-restart 'abort)
     240  (invoke-restart (find-restart-or-control-error 'abort condition))
    238241  (error 'control-error
    239242         :format-control "ABORT restart failed to transfer control dynamically."))
    240243
    241244(defun muffle-warning (&optional condition)
    242   (invoke-restart 'muffle-warning))
     245  (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
    243246
    244247(defun continue (&optional condition)
  • trunk/j/src/org/armedbear/lisp/trace.lisp

    r8333 r8502  
    11;;; trace.lisp
    22;;;
    3 ;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: trace.lisp,v 1.8 2005-01-10 15:42:52 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: trace.lisp,v 1.9 2005-02-08 02:40:49 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3030
    3131(defmacro trace (&rest args)
    32   (setf *trace-depth* 0)
    3332  (if args
    34       (expand-trace args)
    35       '(list-traced-functions)))
     33      `(progn
     34        (setf *trace-depth* 0)
     35        (expand-trace ',args))
     36      `(list-traced-functions)))
    3637
    3738(defun expand-trace (args)
     
    4546      (if (trace-1 arg breakp)
    4647          (push arg results)))
    47     `',results))
     48    results))
    4849
    4950(defun trace-1 (symbol breakp)
     
    5657              (lambda (&rest args)
    5758                (with-standard-io-syntax
    58                     (%format t (indent "~D: ~S~%") *trace-depth*
    59                              (append (list symbol) args)))
     59                    (%format *trace-output* (indent "~D: ~S~%") *trace-depth*
     60                             (cons symbol args)))
    6061                (when breakp
    6162                  (break))
     
    6465                  (decf *trace-depth*)
    6566                  (with-standard-io-syntax
    66                     (%format t (indent "~D: ~A returned") *trace-depth* symbol)
     67                    (%format *trace-output* (indent "~D: ~A returned") *trace-depth* symbol)
    6768                      (dolist (val r)
    68                         (%format t " ~S" val))
    69                       (%format t "~%"))
     69                        (%format *trace-output* " ~S" val))
     70                    (terpri *trace-output*))
    7071                  (values-list r)))))
    71         (setf (symbol-function symbol) trace-function)
     72        (let ((*warn-on-redefinition* nil))
     73          (setf (symbol-function symbol) trace-function))
    7274        (setf (get symbol *untraced-function*) untraced-function)
    7375        (push symbol *traced-functions*)
     
    8082
    8183(defmacro untrace (&rest args)
    82   (setf *trace-depth* 0)
    83   (if (null args)
    84       (untrace-all)
    85       (dolist (arg args)
    86         (if (member arg *traced-functions*)
    87             (untrace-1 arg)
    88             (%format t "~S is not being traced.~%" arg)))))
     84  (cond ((null args)
     85         `(progn
     86            (untrace-all)
     87            (setf *trace-depth* 0)
     88            t))
     89        (t
     90         `(progn
     91            (untrace-n ',args)
     92            (setf *trace-depth* 0)
     93            t))))
    8994
    9095(defun untrace-all ()
     
    9297    (untrace-1 arg)))
    9398
     99(defun untrace-n (args)
     100  (dolist (arg args)
     101    (if (member arg *traced-functions*)
     102        (untrace-1 arg)
     103        (%format t "~S is not being traced.~%" arg))))
     104
    94105(defun untrace-1 (symbol)
    95   (let ((untraced-function (get symbol *untraced-function*)))
     106  (let ((untraced-function (get symbol *untraced-function*))
     107        (*warn-on-redefinition* nil))
    96108    (setf (symbol-function symbol) untraced-function)
    97109    (remprop symbol *untraced-function*)
Note: See TracChangeset for help on using the changeset viewer.