home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
clisp
/
src
/
archive
/
clisp.faslsp.lha
/
conditio.lsp
< prev
next >
Wrap
Text File
|
1996-04-15
|
67KB
|
1,725 lines
;;; Condition System for CLISP
;;; David Gadbois <gadbois@cs.utexas.edu> 30.11.1993
;;; Bruno Haible 24.11.1993, 2.12.1993
(in-package "LISP")
;;; exports:
(export '(
;; types:
restart condition serious-condition error program-error control-error
arithmetic-error division-by-zero floating-point-overflow
floating-point-underflow cell-error unbound-variable undefined-function
type-error package-error print-not-readable stream-error end-of-file
file-error storage-condition warning simple-condition simple-error
simple-type-error simple-warning
;; macros:
define-condition handler-bind ignore-errors handler-case
with-condition-restarts restart-bind restart-case with-restarts
with-simple-restart check-type assert etypecase ctypecase ecase ccase
;; functions:
make-condition arithmetic-error-operation arithmetic-error-operands
cell-error-name type-error-datum type-error-expected-type
package-error-package print-not-readable-object stream-error-stream
file-error-pathname simple-condition-format-string
simple-condition-format-arguments
signal restart-name compute-restarts find-restart invoke-restart
invoke-restart-interactively invoke-debugger break error cerror warn
;; functions and restart names:
abort continue muffle-warning store-value use-value
;; variables:
*break-on-signals* *debugger-hook*
;; extensions:
muffle-cerrors appease-cerrors exit-on-error
))
(in-package "SYSTEM")
;;; Overview of Concepts
; A condition is some information about an exceptional situation the program
; cannot or does not want handle locally.
; A handler is some code that tries to do recovery from exceptional situations
; that happen elsewhere, or that decides to transfer control.
; A restart is a point where control may be transferred to, together with a
; description what is about to happen in this case.
;;; The CONDITION type
; The condition type system is integrated with CLOS.
(clos:defclass condition () ())
; 29.3.18. Printing Conditions when *print-escape* and *print-readably* are NIL.
(clos:defgeneric print-condition (condition stream)
(:method ((condition condition) stream)
(format stream
(formatter
#.
#L{
DEUTSCH "Ausnahmefall vom Typ ~S."
ENGLISH "Condition of type ~S."
FRANCAIS "Condition exceptionnelle de type ~S."
}
)
(type-of condition)
) )
)
(clos:defmethod clos:print-object ((object condition) stream)
(if (or *print-escape* *print-readably*)
(clos:call-next-method)
(print-condition object stream)
) )
;;; 29.4.5. Defining Conditions
; DEFINE-CONDITION, CLtL2 p. 898
(defmacro define-condition (name parent-types slot-specs &rest options)
(unless (symbolp name)
(error-of-type 'program-error
#L{
DEUTSCH "~S: Der Name einer Condition muß ein Symbol sein, nicht: ~S"
ENGLISH "~S: the name of a condition must be a symbol, not ~S"
FRANCAIS "~S : Le nom d'une condition exceptionnelle doit être un symbole et non ~S"
}
'define-condition name
) )
(unless (and (listp parent-types) (every #'symbolp parent-types))
(error-of-type 'program-error
#L{
DEUTSCH "~S: Die Liste der Obertypen muß eine Liste von Symbolen sein, nicht: ~S"
ENGLISH "~S: the parent-type list must be a list of symbols, not ~S"
FRANCAIS "~S : La liste des types doit être une liste de symboles et non ~S"
}
'define-condition parent-types
) )
(unless (listp slot-specs)
(error-of-type 'program-error
#L{
DEUTSCH "~S: Die Liste der Slot-Beschreibungen muß eine Liste sein, nicht: ~S"
ENGLISH "~S: the slot description list must be a list, not ~S"
FRANCAIS "~S : La liste des descriptions de «slots» doit être une listeet non ~S"
}
'define-condition slot-specs
) )
(let ((docstring-option nil)
(report-function nil))
(dolist (option options)
(if (listp option)
(if (and (keywordp (car option)) (eql (length option) 2))
(case (first option)
(:DOCUMENTATION (setq docstring-option option))
(:REPORT (setq report-function (rest option)))
(T (error-of-type 'program-error
#L{
DEUTSCH "~S ~S: Die Option ~S gibt es nicht."
ENGLISH "~S ~S: unknown option ~S"
FRANCAIS "~S ~S : Option ~S non reconnue."
}
'define-condition name (first option)
) ) )
(error-of-type 'program-error
#L{
DEUTSCH "~S ~S: Falsche Syntax in ~S-Option: ~S"
ENGLISH "~S ~S: invalid syntax in ~S option: ~S"
FRANCAIS "~S ~S : Mauvaise syntaxe dans l'option ~S: ~S"
}
'define-condition name option
) )
(error-of-type 'program-error
#L{
DEUTSCH "~S ~S: Das ist keine ~S-Option: ~S"
ENGLISH "~S ~S: not a ~S option: ~S"
FRANCAIS "~S ~S : Ceci n'est pas une option ~S: ~S"
}
'define-condition name option
) ) )
(let ((defclass-form
`(CLOS:DEFCLASS ,name
,(clos::add-default-superclass parent-types 'CONDITION)
,slot-specs
,@(if docstring-option `(,docstring-option))
)
))
(if report-function
`(PROGN
,defclass-form
(CLOS:DEFMETHOD PRINT-CONDITION ((CONDITION ,name) STREAM)
,(if (stringp (first report-function))
`(WRITE-STRING ,(first report-function) STREAM)
`(FUNCALL (FUNCTION ,@report-function) CONDITION STREAM)
)
) )
defclass-form
) ) ) )
;;; 29.4.6. Creating Conditions
; MAKE-CONDITION, CLtL2 p. 901
(defun make-condition (type &rest slot-initializations)
(unless (subtypep type 'condition)
(error-of-type 'error
#L{
DEUTSCH "~S: Typ ~S ist kein Untertyp von ~S."
ENGLISH "~S: type ~S is not a subtype of ~S"
FRANCAIS "~S : Le type ~S n'est pas un sous-type de ~S."
}
'make-condition type 'condition
) )
(apply #'clos:make-instance type slot-initializations)
)
; canonicalize a condition argument, CLtL2 p. 888
(defun coerce-to-condition (datum arguments
caller-name
default-type &rest more-initargs)
(typecase datum
(condition
(when arguments
(error-of-type 'type-error
:datum arguments :expected-type 'null
#L{
DEUTSCH "~S ~S: Überflüssige Argumente ~S"
ENGLISH "~S ~S: superfluous arguments ~S"
FRANCAIS "~S ~S : Les arguments ~S sont superflus."
}
caller-name datum arguments
) )
datum
)
(symbol
(apply #'make-condition datum arguments)
)
((or string function) ; only this case uses default-type and more-initargs
(apply #'make-condition default-type
#-dpANS :format-string #+dpANS :format-control datum
:format-arguments arguments
more-initargs
) )
(t
(error-of-type 'type-error
:datum datum :expected-type '(or condition symbol string function)
#L{
DEUTSCH "~S: Condition-Argument muß ein String, ein Symbol oder eine Condition sein, nicht ~S"
ENGLISH "~S: the condition argument must be a string, a symbol or a condition, not ~S"
FRANCAIS "~S : L'argument de condition exceptionnelle doit être de type STRING, SYMBOL ou CONDITION et non ~S"
}
caller-name datum
) ) ) )
;;; 29.5. Predefined Condition Types
; Hierarchy:
;
; condition
; |
; |-- simple-condition
; |
; |-- serious-condition
; | |
; | |-- error
; | | |
; | | |-- simple-error
; | | |
; | | |-- arithmetic-error
; | | | |
; | | | |-- division-by-zero
; | | | |
; | | | |-- floating-point-overflow
; | | | |
; | | | |-- floating-point-underflow
; | | |
; | | |-- cell-error
; | | | |
; | | | |-- unbound-variable
; | | | |
; | | | |-- undefined-function
; | | |
; | | |-- control-error
; | | |
; | | |-- file-error
; | | |
; | | |-- package-error
; | | |
; | | |-- print-not-readable
; | | |
; | | |-- program-error
; | | |
; | | |-- stream-error
; | | | |
; | | | |-- end-of-file
; | | |
; | | |-- type-error
; | | |
; | | |-- simple-type-error
; | |
; | |-- storage-condition
; |
; |-- warning
; |
; |-- simple-warning
;
; conditions that require interactive intervention
(define-condition serious-condition () ())
; serious conditions that occur deterministically
(define-condition error (serious-condition) ())
; statically detectable errors of a program
(define-condition program-error (error) ())
; all the other errors must be detected by the runtime system
; not statically detectable errors in program control
(define-condition control-error (error) ())
; errors that occur while doing arithmetic operations
(define-condition arithmetic-error (error)
((operation :initarg :operation :reader arithmetic-error-operation)
(operands :initarg :operands :reader arithmetic-error-operands)
) )
; trying to evaluate a mathematical function at a singularity
(define-condition division-by-zero (arithmetic-error) ())
; trying to get too close to infinity in the floating point domain
(define-condition floating-point-overflow (arithmetic-error) ())
; trying to get too close to zero in the floating point domain
(define-condition floating-point-underflow (arithmetic-error) ())
#+dpANS (define-condition floating-point-inexact (arithmetic-error) ())
#+dpANS (define-condition floating-point-invalid-operation (arithmetic-error) ())
; trying to access a location which contains #<UNBOUND>
(define-condition cell-error (error)
((name :initarg :name :reader cell-error-name))
)
; trying to get the value of an unbound variable
(define-condition unbound-variable (cell-error) ())
; trying to get the global function definition of an undefined function
(define-condition undefined-function (cell-error) ())
#+dpANS (define-condition unbound-slot (cell-error)
((instance :initarg :instance :reader unbound-slot-instance))
)
; when some datum does not belong to the expected type
(define-condition type-error (error)
((datum :initarg :datum :reader type-error-datum)
(expected-type :initarg :expected-type :reader type-error-expected-type)
) )
; errors during operation on packages
(define-condition package-error (error)
((package :initarg :package :reader package-error-package))
)
; attempted violation of *PRINT-READABLY*
(define-condition print-not-readable (error)
((object :initarg :object :reader print-not-readable-object))
)
#+dpANS (define-condition parse-error (error) ())
; errors while doing stream I/O
(define-condition stream-error (error)
((stream :initarg :stream :reader stream-error-stream))
)
; unexpected end of stream
(define-condition end-of-file (stream-error) ())
#+dpANS (define-condition reader-error (parse-error stream-error) ())
; errors with pathnames, OS level errors with streams
(define-condition file-error (error)
((pathname :initarg :pathname :reader file-error-pathname))
)
; "Virtual memory exhausted"
(define-condition storage-condition (serious-condition) ())
; conditions for which user notification is appropriate
(define-condition warning () ())
#+dpANS (define-condition style-warning (warning) ())
;; These shouldn't be separate types but we cannot adjoin slots without
;; defining subtypes.
; conditions usually created by SIGNAL
(define-condition simple-condition ()
(#-dpANS (format-string :initarg :format-string :initform nil
:reader simple-condition-format-string
)
#+dpANS (format-control :initarg :format-control :initform nil
:reader simple-condition-format-string
:reader simple-condition-format-control
)
(format-arguments :initarg :format-arguments :initform nil
:reader simple-condition-format-arguments
))
#|
(:report
(lambda (condition stream)
(let ((fstring (simple-condition-format-string condition)))
(when fstring
(apply #'format stream fstring (simple-condition-format-arguments condition))
) ) ) )
|#
)
; We don't use the :report option here. Instead we define a print-condition
; method which will be executed regardless of the condition type's CPL.
(clos:defmethod print-condition :around ((condition simple-condition) stream)
(let ((fstring (simple-condition-format-string condition)))
(if fstring
(apply #'format stream fstring (simple-condition-format-arguments condition))
(clos:call-next-method)
) ) )
; conditions usually created by ERROR or CERROR
(define-condition simple-error (simple-condition error) ())
; conditions usually created by CHECK-TYPE
(define-condition simple-type-error (simple-error type-error) ())
; conditions usually created by WARN
(define-condition simple-warning (simple-condition warning) ())
; All conditions created by the C runtime code are of type simple-condition.
; Need the following types. Don't use them for discrimination.
(define-condition simple-serious-condition (simple-condition serious-condition) ())
(define-condition simple-program-error (simple-error program-error) ())
(define-condition simple-control-error (simple-error control-error) ())
(define-condition simple-arithmetic-error (simple-error arithmetic-error) ())
(define-condition simple-division-by-zero (simple-error division-by-zero) ())
(define-condition simple-floating-point-overflow (simple-error floating-point-overflow) ())
(define-condition simple-floating-point-underflow (simple-error floating-point-underflow) ())
(define-condition simple-cell-error (simple-error cell-error) ())
(define-condition simple-unbound-variable (simple-error unbound-variable) ())
(define-condition simple-undefined-function (simple-error undefined-function) ())
(define-condition simple-package-error (simple-error package-error) ())
(define-condition simple-print-not-readable (simple-error print-not-readable) ())
(define-condition simple-stream-error (simple-error stream-error) ())
(define-condition simple-end-of-file (simple-error end-of-file) ())
(define-condition simple-file-error (simple-error file-error) ())
(define-condition simple-storage-condition (simple-condition storage-condition) ())
; Bootstrapping
(%defclcs
; The order of the types in this vector must be the same as in lispbibl.d.
'#((condition . simple-condition)
(serious-condition . simple-serious-condition)
(error . simple-error)
(program-error . simple-program-error)
(control-error . simple-control-error)
(arithmetic-error . simple-arithmetic-error)
(division-by-zero . simple-division-by-zero)
(floating-point-overflow . simple-floating-point-overflow)
(floating-point-underflow . simple-floating-point-underflow)
(cell-error . simple-cell-error)
(unbound-variable . simple-unbound-variable)
(undefined-function . simple-undefined-function)
(type-error . simple-type-error)
(package-error . simple-package-error)
(print-not-readable . simple-print-not-readable)
(stream-error . simple-stream-error)
(end-of-file . simple-end-of-file)
(file-error . simple-file-error)
(storage-condition . simple-storage-condition)
(warning . simple-warning)
)
)
;;; Handling and Signalling - Primitives
(defvar *break-on-signals* nil)
#|
; This would be a possible implementation. However, it forces too many
; variables into closures although in the most frequent case - no condition
; at all - they won't be needed. Furthermore, it conses too much.
; List of active invocations of HANDLER-BIND.
(defvar *handler-clusters* '())
;; HANDLER-BIND, CLtL2 p. 898
(defmacro handler-bind (clauses &body body)
`(LET ((*HANDLER-CLUSTERS*
(CONS
(LIST ,@(mapcar #'(lambda (clause)
(let ((type (first clause))
(function-form (second clause)))
`(CONS ',type ,function-form)
) )
clauses
)
)
*HANDLER-CLUSTERS*
)) )
(PROGN ,@body)
)
)
;; SIGNAL, CLtL2 p. 888
(defun signal (datum &rest arguments)
(let ((condition
(coerce-to-condition datum arguments 'signal
'simple-condition ; CLtL2 p. 918 specifies this
)) )
(when (typep condition *break-on-signals*)
; Enter the debugger prior to signalling the condition
(restart-case (invoke-debugger condition)
(continue ())
) )
; CLtL2 p. 884: "A handler is executed in the dynamic context of the
; signaler, except that the set of available condition handlers will
; have been rebound to the value that was active at the time the condition
; handler was made active."
(let ((*handler-clusters* *handler-clusters*))
(loop
(when (null *handler-clusters*) (return))
(dolist (handler (pop *handler-clusters*))
(when (typep condition (car handler))
(funcall (cdr handler) condition)
(return)
) ) ) )
nil
) )
|#
;; HANDLER-BIND, CLtL2 p. 898
; Since we can build handler frames only in compiled code
; there is SYS::%HANDLER-BIND which is synonymous to HANDLER-BIND except
; that SYS::%HANDLER-BIND only occurs in compiled code.
(defmacro handler-bind (clauses &body body)
(let ((typespecs (mapcar #'first clauses))
(handlers (append (mapcar #'rest clauses) (list body))))
(let ((handler-vars
(mapcar #'(lambda (x) (declare (ignore x)) (gensym)) handlers)
))
`(LET ,(mapcar #'list
handler-vars
(mapcar #'(lambda (handler) `(FUNCTION (LAMBDA () (PROGN ,@handler))))
handlers
) )
(LOCALLY (DECLARE (COMPILE))
(SYS::%HANDLER-BIND
,(mapcar #'(lambda (typespec handler-var)
`(,typespec #'(LAMBDA (CONDITION) (FUNCALL (FUNCALL ,handler-var) CONDITION)))
)
typespecs handler-vars
)
(FUNCALL ,(car (last handler-vars)))
) ) )
) ) )
;; SIGNAL, CLtL2 p. 888
; is in error.d
;;; Handling and Signalling - Part 2
;; IGNORE-ERRORS, CLtL2 p. 897
(defmacro ignore-errors (&body body)
(let ((blockname (gensym)))
`(BLOCK ,blockname
(HANDLER-BIND
((ERROR #'(LAMBDA (CONDITION) (RETURN-FROM ,blockname (VALUES NIL CONDITION)))))
,@body
) )
) )
;; HANDLER-CASE, CLtL2 p. 895
(defmacro handler-case (form &rest clauses)
; split off the :NO-ERROR clause and
; add a GO tag to the other clauses (type varlist . body)
(let ((no-error-clause nil) ; the last clause, if it is a :no-error clause
(extended-clauses '())) ; ((tag type varlist . body) ...)
(do ()
((endp clauses))
(let ((clause (pop clauses)))
(block check-clause
(unless (and (consp clause) (consp (cdr clause)) (listp (second clause)))
(error-of-type 'program-error
#L{
DEUTSCH "~S: Illegale Syntax für Klausel: ~S"
ENGLISH "~S: illegal syntax of clause ~S"
FRANCAIS "~S : syntaxe inadmissible de la phrase ~S"
}
'handler-case clause
) )
(when (eq (first clause) ':no-error)
(if (null clauses) ; at the end of the clauses?
(progn (setq no-error-clause clause) (return-from check-clause))
(warn
#L{
DEUTSCH "~S: ~S-Klausel an falscher Stelle: ~S"
ENGLISH "~S: misplaced ~S clause: ~S"
FRANCAIS "~S : phrase ~S mal placée: ~S"
}
'handler-case ':no-error clause
) ) )
(let ((varlist (second clause))) ; known as a list
(unless (null (cdr varlist))
(error-of-type 'program-error
#L{
DEUTSCH "~S: Zu viele Variablen ~S in Klausel ~S"
ENGLISH "~S: too many variables ~S in clause ~S"
FRANCAIS "~S : trop de variables ~S dans la phrase ~S"
}
'handler-case varlist clause
) ) )
(push (cons (gensym) clause) extended-clauses)
) ) )
(setq extended-clauses (nreverse extended-clauses))
(let ((blockname (gensym))
(tempvar (gensym)))
`(BLOCK ,blockname
(LET (,tempvar) ; tempvar is IGNORABLE since it is a gensym
(TAGBODY
(RETURN-FROM ,blockname
,(let ((main-form
`(HANDLER-BIND
,(mapcar #'(lambda (xclause)
(let ((tag (first xclause))
(type (first (rest xclause)))
(varlist (second (rest xclause))))
`(,type
#'(LAMBDA (CONDITION)
,(if (null varlist)
`(DECLARE (IGNORE CONDITION))
`(SETQ ,tempvar CONDITION)
)
(GO ,tag)
) )
) )
extended-clauses
)
,form
)
))
(if no-error-clause
`(MULTIPLE-VALUE-CALL #'(LAMBDA ,@(rest no-error-clause))
,main-form
)
main-form
) )
)
,@(mapcap #'(lambda (xclause)
(let ((tag (first xclause))
(varlist (second (rest xclause)))
(body (cddr (rest xclause)))) ; may contain declarations
`(,tag
(RETURN-FROM ,blockname
(LET ,(if (null varlist) '() `((,@varlist ,tempvar)))
,@body
)) )
) )
extended-clauses
)
) ) )
) ) )
;;; Restarts
;; This stuff is needed only once an exception has already occurred. No need
;; to optimize the hell out of it.
; The default test function for restarts always returns T. See CLtL2 p. 905,909.
(defun default-restart-test (condition)
(declare (ignore condition))
t
)
; The default interactive function for restarts returns the empty argument list.
(defun default-restart-interactive ()
'()
)
;; The RESTART type, CLtL2 p. 916
;; Also defines RESTART-NAME, CLtL2 p. 911
(defstruct (restart (:print-function print-restart))
name ; its name, or NIL if it is not named
(test #'default-restart-test) ; function that tests whether this restart
; applies to a given condition
(invoke-tag nil) ; tag used to invoke the restart, or nil
invoke-function ; function used to invoke the restart, if invoke-tag is nil
(report nil) ; function used to print a description of the restart
(interactive #'default-restart-interactive)
; function used to gather additional data from the user
; before invoking the restart
)
#| ; We could also define it as a CLOS class:
(clos:defclass restart ()
(name :initarg :name :reader restart-name)
(test :initarg :test :reader restart-test
:initform #'default-restart-test
)
(invoke-tag :initarg :invoke-tag :reader restart-invoke-tag
:initform nil
)
(invoke-function :initarg :invoke-function :reader restart-invoke-function)
(report :initarg :report :reader restart-report
:initform nil
)
(interactive :initarg :interactive :reader restart-interactive
:initform #'default-restart-interactive
)
)
|#
;; Printing restarts
(defun print-restart (restart stream depth)
(declare (ignore depth))
(if (or *print-escape* *print-readably*)
(print-unreadable-object (restart stream :type t :identity t)
(write (restart-name restart) :stream stream)
)
(let ((report-function (restart-report restart)))
(if report-function
(funcall report-function stream)
(prin1 (restart-name restart) stream)
) ) ) )
#| ; If RESTART were a CLOS class:
(clos:defmethod clos:print-object ((restart restart) stream)
(if (or *print-escape* *print-readably*)
(clos:call-next-method)
(let ((report-function (restart-report restart)))
(if report-function
(funcall report-function stream)
(prin1 (restart-name restart) stream)
) ) ) )
|#
;; Expands to the equivalent of `(MAKE-RESTART :NAME name ...)
;; but makes intelligent use of the defaults to reduce code size.
(defun make-restart-form (name test invoke-tag invoke-function report interactive)
`(MAKE-RESTART
:NAME ,name
,@(if (not (equal test '(FUNCTION DEFAULT-RESTART-TEST)))
`(:TEST ,test)
)
,@(if (not (equal invoke-tag 'NIL))
`(:INVOKE-TAG ,invoke-tag)
)
:INVOKE-FUNCTION ,invoke-function
,@(if (not (equal report 'NIL))
`(:REPORT ,report)
)
,@(if (not (equal interactive '(FUNCTION DEFAULT-RESTART-INTERACTIVE)))
`(:INTERACTIVE ,interactive)
)
)
)
;; The list of active restarts.
(defvar *active-restarts* nil)
;; A list of pairs of conditions and restarts associated with them. We have to
;; keep the associations separate because there can be a many-to-many mapping
;; between restarts and conditions, and this mapping has dynamic extent.
(defvar *condition-restarts* nil)
; Add an association between a condition and a couple of restarts.
(defun add-condition-restarts (condition restarts)
(dolist (restart restarts)
(push (cons condition restart) *condition-restarts*)
) )
;; WITH-CONDITION-RESTARTS, CLtL2 p. 910
(defmacro with-condition-restarts (condition-form restarts-form &body body)
`(LET ((*CONDITION-RESTARTS* *CONDITION-RESTARTS*))
(ADD-CONDITION-RESTARTS ,condition-form ,restarts-form)
(LET () ,@body)
)
)
;;; 29.4.8. Finding and Manipulating Restarts
; Tests whether a given restart is applicable to a given condition
(defun applicable-restart-p (restart condition)
(and
#| ; We choose the dpANS behaviour because it makes the need for the
; syntax-dependent implicit restart association in RESTART-CASE
; nearly obsolete.
#-dpANS
; A restart is applicable iff it is associated to that condition.
(dolist (asso *condition-restarts* nil)
(when (and (eq (car asso) condition) (eq (cdr asso) restart))
(return t)
) )
#+dpANS
|#
; A restart is applicable if it is associated to that condition
; or if it is not associated to any condition.
(let ((not-at-all t))
(dolist (asso *condition-restarts* not-at-all)
(when (eq (cdr asso) restart)
(if (eq (car asso) condition)
(return t)
(setq not-at-all nil)
) ) ) )
; Call the restart's test function:
(funcall (restart-test restart) condition)
) )
;; COMPUTE-RESTARTS, CLtL2 p. 910
(defun compute-restarts (&optional condition)
(if condition
; return only restarts that are applicable to that condition
(remove-if-not #'(lambda (restart) (applicable-restart-p restart condition))
*active-restarts*
)
; return all restarts
*active-restarts*
) )
;; FIND-RESTART, CLtL2 p. 911
; returns a restart or nil
(defun find-restart (restart-identifier &optional condition)
(cond ((null restart-identifier)
(error-of-type 'error
#L{
DEUTSCH "~S: ~S ist als Restart-Name hier nicht zulässig. Verwenden Sie ~S."
ENGLISH "~S: ~S is not a valid restart name here. Use ~S instead."
FRANCAIS "~S : ~S n'est pas valable comme nom de «restart» ici. Utilisez ~S."
}
'find-restart restart-identifier 'compute-restarts
))
((symbolp restart-identifier)
(dolist (restart *active-restarts*)
(when (and (eq (restart-name restart) restart-identifier)
(or (null condition)
(applicable-restart-p restart condition)
) )
(return restart)
)) )
((typep restart-identifier 'restart)
(dolist (restart *active-restarts*)
(when (and (eq restart restart-identifier)
(or (null condition)
(applicable-restart-p restart condition)
) )
(return restart)
)) )
(t (error-of-type 'type-error
:datum restart-identifier :expected-type '(or symbol restart)
#L{
DEUTSCH "~S: Ungültiger Restart-Name: ~S"
ENGLISH "~S: invalid restart name ~S"
FRANCAIS "~S : Nom inadmissible pour un «restart»: ~S"
}
'find-restart restart-identifier
) )
) )
(defun restart-not-found (restart-identifier)
(error-of-type 'control-error
#L{
DEUTSCH "~S: Ein Restart mit Namen ~S ist nicht sichtbar."
ENGLISH "~S: No restart named ~S is visible."
FRANCAIS "~S : Un «restart» de nom ~S n'est pas visible."
}
'invoke-restart restart-identifier
) )
(defun %invoke-restart (restart arguments)
(if (restart-invoke-tag restart)
(throw (restart-invoke-tag restart) arguments)
(apply (restart-invoke-function restart) arguments)
; This may return normally, the restart need not transfer control.
; (See CLtL2 p. 880.)
) )
;; INVOKE-RESTART, CLtL2 p. 911
(defun invoke-restart (restart-identifier &rest arguments)
(let ((restart (find-restart restart-identifier)))
(unless restart (restart-not-found restart-identifier))
(%invoke-restart restart arguments)
) )
(defun invoke-restart-condition (restart-identifier condition &rest arguments)
(let ((restart (find-restart restart-identifier condition)))
(unless restart (restart-not-found restart-identifier))
(%invoke-restart restart arguments)
) )
(defun invoke-restart-condition-if-exists (restart-identifier condition &rest arguments)
(let ((restart (find-restart restart-identifier condition)))
(when restart
(%invoke-restart restart arguments)
) ) )
;; INVOKE-RESTART-INTERACTIVELY, CLtL2 p. 911
(defun invoke-restart-interactively (restart-identifier)
(let ((restart (find-restart restart-identifier)))
(unless restart (restart-not-found restart-identifier))
(let ((arguments (funcall (restart-interactive restart))))
(%invoke-restart restart arguments)
) ) )
;;; 29.4.7. Establishing Restarts
;; This conses out the wazoo, but there seems to be no good way around it short
;; of special casing things a zillion ways. The main problem is that someone
;; could write:
;;
;; (restart-bind ((nil *fun-1*
;; :interactive-function *fun-2*
;; :report-function *fun-3*
;; :test-function *fun-4*
;; )) ...)
;;
;; and it is supposed to work.
;; RESTART-BIND, CLtL2 p. 909
(defmacro restart-bind (restart-specs &body body)
(setq body `(PROGN ,@body))
(unless (listp restart-specs)
(error-of-type 'program-error
#L{
DEUTSCH "~S: Das ist keine Liste: ~S"
ENGLISH "~S: not a list: ~S"
FRANCAIS "~S : ceci n'est pas une liste: ~S"
}
'restart-bind restart-specs
) )
(if restart-specs
`(LET ((*ACTIVE-RESTARTS*
(LIST*
,@(mapcar #'(lambda (spec)
(unless (and (listp spec) (consp (cdr spec)) (symbolp (first spec)))
(error-of-type 'program-error
#L{
DEUTSCH "~S: Ungültige Restart-Spezifikation: ~S"
ENGLISH "~S: invalid restart specification ~S"
FRANCAIS "~S : spécification inadmissible d'un «restart»: ~S"
}
'restart-bind spec
) )
(apply #'(lambda (name function
&key (test-function '(FUNCTION DEFAULT-RESTART-TEST))
(interactive-function '(FUNCTION DEFAULT-RESTART-INTERACTIVE))
(report-function 'NIL))
(when (and (null name) (eq report-function 'NIL))
; CLtL2 p. 906: "It is an error if an unnamed restart is used
; and no report information is provided."
(error-of-type 'program-error
#L{
DEUTSCH "~S: Bei unbenannten Restarts muß ~S angegeben werden: ~S"
ENGLISH "~S: unnamed restarts require ~S to be specified: ~S"
FRANCAIS "~S : Il faut spécifier ~S pour des «restarts» anonymes: ~S"
}
'restart-bind ':REPORT-FUNCTION spec
) )
(make-restart-form `',name
test-function
'NIL
function
report-function
interactive-function
) )
spec
) )
restart-specs
)
*ACTIVE-RESTARTS*
)) )
,body
)
body
) )
;; RESTART-CASE, CLtL2 p. 903
;; WITH-RESTARTS
;; Syntax: (RESTART-CASE form {restart-clause}*)
;; (WITH-RESTARTS ({restart-clause}*) {form}*)
;; restart-clause ::= (restart-name arglist {keyword value}* {form}*)
;; | (restart-name {keyword value}* arglist {form}*)
;; There are a number of special cases we could optimize for. If we
;; can determine that we will not have to cons any closures at
;; runtime, then we could statically allocate the list of restarts.
;;
;; Since we have to deal with the wacky way RESTART-CASE interacts with
;; WITH-CONDITION-RESTARTS, we do not go through RESTART-BIND.
(eval-when (compile load eval)
(defun expand-restart-case (caller restart-clauses form)
(unless (listp restart-clauses)
(error-of-type 'program-error
#L{
DEUTSCH "~S: Das ist keine Liste: ~S"
ENGLISH "~S: not a list: ~S"
FRANCAIS "~S : ceci n'est pas une liste: ~S"
}
caller restart-clauses
) )
(let ((xclauses ; list of expanded clauses
; ((tag name test interactive report lambdalist . body) ...)
(mapcar
#'(lambda (restart-clause &aux (clause restart-clause))
(unless (and (consp clause) (consp (cdr clause)) (symbolp (first clause)))
(error-of-type 'program-error
#L{
DEUTSCH "~S: Ungültige Restart-Spezifikation: ~S"
ENGLISH "~S: invalid restart specification ~S"
FRANCAIS "~S : spécification inadmissible d'un «restart»: ~S"
}
caller clause
) )
(let ((name (pop clause))
(passed-arglist nil)
(passed-keywords nil)
arglist
(keywords '()))
(loop
(when (endp clause) (return))
(cond ((and (not passed-arglist) (listp (first clause)))
(setq arglist (pop clause))
(setq passed-arglist t)
(when keywords (setq passed-keywords t))
)
((and (not passed-keywords) (consp (cdr clause)) (keywordp (first clause)))
(push (pop clause) keywords)
(push (pop clause) keywords)
)
(t (return))
) )
(unless passed-arglist
(error-of-type 'program-error
#L{
DEUTSCH "~S: Restart-Spezifikation ohne Lambda-Liste: ~S"
ENGLISH "~S: missing lambda list in restart specification ~S"
FRANCAIS "~S : il faut une liste lambda dans la spécification d'un «restart»: ~S"
}
caller clause
) )
(multiple-value-bind (test interactive report)
(apply #'(lambda (&key (test 'DEFAULT-RESTART-TEST)
(interactive 'DEFAULT-RESTART-INTERACTIVE)
(report 'DEFAULT-RESTART-REPORT))
(values test interactive report)
)
(nreverse keywords)
)
(when (and (null name) (eq report 'DEFAULT-RESTART-REPORT))
; CLtL2 p. 906: "It is an error if an unnamed restart is used
; and no report information is provided."
(error-of-type 'program-error
#L{
DEUTSCH "~S: Bei unbenannten Restarts muß ~S angegeben werden: ~S"
ENGLISH "~S: unnamed restarts require ~S to be specified: ~S"
FRANCAIS "~S : Il faut spécifier ~S pour des «restarts» anonymes: ~S"
}
caller ':REPORT restart-clause
) )
(when (and (consp arglist) (not (member (first arglist) lambda-list-keywords))
(eq interactive 'DEFAULT-RESTART-INTERACTIVE)
)
; restart takes required arguments but does not have an
; interactive function that will prompt for them.
(warn
#L{
DEUTSCH "~S: Restart kann nicht interaktiv aufgerufen werden, weil ~S fehlt: ~S"
ENGLISH "~S: restart cannot be invoked interactively because it is missing a ~S option: ~S"
FRANCAIS "~S : Ce «restart» ne peut prendre le contrôle en dialogue car il manque un ~S : ~S"
}
caller ':INTERACTIVE restart-clause
) )
`(,(gensym)
,name
,test ,interactive ,report
,arglist
,@clause
)
) ) )
restart-clauses
) )
(blockname (gensym))
(arglistvar (gensym))
(associate
;; Yick. As a pretty lame way of allowing for an
;; association between conditions and restarts,
;; RESTART-CASE has to notice if its body is signalling a
;; condition, and, if so, associate the restarts with the
;; condition.
(and (consp form)
(case (first form) ((SIGNAL ERROR CERROR WARN) t) (t nil))
(gensym)
)) )
`(BLOCK ,blockname
(LET (,arglistvar) ; arglistvar is IGNORABLE since it is a gensym
(TAGBODY
,(let ((restart-forms
(mapcar #'(lambda (xclause)
(let ((tag (first xclause))
(name (second xclause))
(test (third xclause))
(interactive (fourth xclause))
(report (fifth xclause)))
(make-restart-form `',name
`(FUNCTION ,test)
'NIL
`(FUNCTION
(LAMBDA (&REST ARGUMENTS)
(SETQ ,arglistvar ARGUMENTS)
(GO ,tag)
) )
(if (eq report 'DEFAULT-RESTART-REPORT)
`NIL
`(FUNCTION
,(if (stringp report)
`(LAMBDA (STREAM) (WRITE-STRING ,report STREAM))
report
)
)
)
`(FUNCTION ,interactive)
)
) )
xclauses
) )
(form `(RETURN-FROM ,blockname ,form)))
`(LET* ,(if associate
`((,associate (LIST ,@restart-forms))
(*ACTIVE-RESTARTS* (APPEND ,associate *ACTIVE-RESTARTS*))
(*CONDITION-RESTARTS* *CONDITION-RESTARTS*)
)
`((*ACTIVE-RESTARTS* (LIST* ,@restart-forms *ACTIVE-RESTARTS*)))
)
,(if associate
#| ; This code resignals the condition in a different dynamic context!
`(LET ((CONDITION
(HANDLER-CASE ,form ; evaluate the form
(CONDITION (C) C) ; catch the condition
)) )
(WITH-CONDITION-RESTARTS CONDITION ,associate ; associate the condition with the restarts
(SIGNAL CONDITION) ; resignal the condition
) )
|#
#| ; This code invokes the debugger even if it shouldn't!
`(HANDLER-BIND
((CONDITION ; catch the condition
#'(LAMBDA (CONDITION)
(WITH-CONDITION-RESTARTS CONDITION ,associate ; associate the condition with the restarts
(SIGNAL CONDITION) ; resignal the condition
(INVOKE-DEBUGGER CONDITION) ; this is weird!
)) ) )
,form
)
|#
`(HANDLER-BIND
((CONDITION ; catch the condition
#'(LAMBDA (CONDITION)
(ADD-CONDITION-RESTARTS CONDITION ,associate) ; associate the condition with the restarts
(SIGNAL CONDITION) ; resignal the condition
)) )
,form
)
form
)
)
)
,@(mapcap #'(lambda (xclause)
(let ((tag (first xclause))
(lambdabody (cdddr (cddr xclause))))
`(,tag
(RETURN-FROM ,blockname
(APPLY (FUNCTION (LAMBDA ,@lambdabody)) ,arglistvar)
))
) )
xclauses
)
) ) )
) )
)
(defmacro restart-case (form &rest restart-clauses)
(expand-restart-case 'restart-case restart-clauses form)
)
(defmacro with-restarts (restart-clauses &body body)
(expand-restart-case 'with-restarts restart-clauses `(PROGN ,@body))
)
;; WITH-SIMPLE-RESTART, CLtL2 p. 902
(defmacro with-simple-restart ((name format-string &rest format-arguments) &body body)
(if (or format-arguments (not (constantp format-string)))
`(WITH-RESTARTS
((,name
:REPORT (LAMBDA (STREAM) (FORMAT STREAM ,format-string ,@format-arguments))
() (VALUES NIL T)
))
,@body
)
;; Here's an example of how we can easily optimize things. There is no
;; need to refer to anything in the lexical environment, so we can avoid
;; consing a restart at run time.
(let ((blockname (gensym))
(tag (gensym)))
`(BLOCK ,blockname
(CATCH ',tag
(LET ((*ACTIVE-RESTARTS*
(CONS
(LOAD-TIME-VALUE
(MAKE-RESTART :NAME ',name
:INVOKE-TAG ',tag
:REPORT #'(LAMBDA (STREAM) (FORMAT STREAM ,format-string))
) )
*ACTIVE-RESTARTS*
)) )
(RETURN-FROM ,blockname (PROGN ,@body))
)
(VALUES NIL T)
) )
) ) )
;;; 29.4.10. Restart Functions
;; These functions are customary way to pass control from a handler to a
;; restart. They just invoke the restart of the same name.
;; ABORT, CLtL2 p. 913
(defun abort (&optional condition)
(invoke-restart-condition 'abort condition)
)
;; CONTINUE, CLtL2 p. 913
(defun continue (&optional condition)
(invoke-restart-condition-if-exists 'continue condition)
)
;; MUFFLE-WARNING, CLtL2 p. 913
(defun muffle-warning (&optional condition)
(invoke-restart-condition 'muffle-warning condition)
)
;; STORE-VALUE, CLtL2 p. 913
(defun store-value (value &optional condition)
(invoke-restart-condition-if-exists 'store-value condition value)
)
;; USE-VALUE, CLtL2 p. 914
(defun use-value (value &optional condition)
(invoke-restart-condition-if-exists 'use-value condition value)
)
;;; 29.4.2. Assertions
;; These macros supersede the corresponding ones from macros2.lsp.
(defun report-new-value (stream)
(write-string
#L{
DEUTSCH "Sie dürfen einen neuen Wert eingeben."
ENGLISH "You may input a new value."
FRANCAIS "Vous avez l'occasion d'entrer une nouvelle valeur."
}
stream
) )
(defun prompt-for-new-value (place)
(format *query-io*
#L{
DEUTSCH "~%Neues ~S: "
ENGLISH "~%New ~S: "
FRANCAIS "~%Nouveau ~S : "
}
place
)
(read *query-io*)
)
;; CHECK-TYPE, CLtL2 p. 889
(defmacro check-type (place typespec &optional (string nil))
(let ((tag1 (gensym))
(tag2 (gensym))
(var (gensym)))
`(TAGBODY
,tag1
(LET ((,var ,place))
(WHEN (TYPEP ,var ',typespec) (GO ,tag2))
(RESTART-CASE
(ERROR-OF-TYPE 'TYPE-ERROR
:DATUM ,var :EXPECTED-TYPE ',typespec
#L{
DEUTSCH "~A~%Der Wert ist: ~S"
ENGLISH "~A~%The value is: ~S"
FRANCAIS "~A~%La valeur est : ~S"
}
,(format nil
#L{
DEUTSCH "Der Wert von ~S sollte ~:[vom Typ ~S~;~:*~A~] sein."
ENGLISH "The value of ~S should be ~:[of type ~S~;~:*~A~]."
FRANCAIS "La valeur de ~S devrait être ~:[de type ~S~;~:*~A~]."
}
place string typespec
)
,var
)
; only one restart, will "continue" invoke it?
(STORE-VALUE
:REPORT REPORT-NEW-VALUE
:INTERACTIVE (LAMBDA () (LIST (PROMPT-FOR-NEW-VALUE ',place)))
(NEW-VALUE) (SETF ,place NEW-VALUE)
)
) )
(GO ,tag1)
,tag2
)
) )
(defun report-no-new-value (stream)
(write-string
#L{
DEUTSCH "Neuer Anlauf"
ENGLISH "Retry"
FRANCAIS "Reéssayer"
}
stream
) )
(defun report-new-values (stream)
(write-string
#L{
DEUTSCH "Sie dürfen neue Werte eingeben."
ENGLISH "You may input new values."
FRANCAIS "Vous pouvez entrer de nouvelles valeurs."
}
stream
) )
;; ASSERT, CLtL2 p. 891
(defmacro assert (test-form &optional (place-list nil) (datum nil) &rest args)
(let ((tag1 (gensym))
(tag2 (gensym)))
`(TAGBODY
,tag1
(WHEN ,test-form (GO ,tag2))
(RESTART-CASE
(PROGN ; no need for explicit association, see applicable-restart-p
(ERROR ; of-type ??
,@(if datum
`(,datum ,@args) ; use coerce-to-condition??
`("~A"
,(format nil
#L{
DEUTSCH "Der Wert von ~S darf nicht NIL sein."
ENGLISH "~S must evaluate to a non-NIL value."
FRANCAIS "La valeur de ~S ne peut pas être NIL."
}
test-form
))
)
) )
; only one restart: CONTINUE
(CONTINUE
:REPORT ,(case (length place-list)
(0 'REPORT-NO-NEW-VALUE)
(1 'REPORT-NEW-VALUE)
(t 'REPORT-NEW-VALUES)
)
:INTERACTIVE
(LAMBDA ()
(LIST
,@(mapcar #'(lambda (place) `(PROMPT-FOR-NEW-VALUE ',place))
place-list
)
) )
,@(let ((new-value-vars
(mapcar #'(lambda (place) (declare (ignore place)) (gensym))
place-list
)) )
`(,new-value-vars
,@(mapcar #'(lambda (place var) `(SETF ,place ,var))
place-list new-value-vars
) )
)
) )
(GO ,tag1)
,tag2
)
) )
;;; 29.4.3. Exhaustive Case Analysis
;; These macros supersede the corresponding ones from macros2.lsp.
(flet ((typecase-errorstring (keyform keyclauselist)
(let ((typelist (mapcar #'first keyclauselist)))
(format nil
#L{
DEUTSCH "Der Wert von ~S muß einem der Typen ~{~S~^, ~} angehören."
ENGLISH "The value of ~S must be of one of the types ~{~S~^, ~}"
FRANCAIS "La valeur de ~S doit appartenir à l'un des types ~{~S~^, ~}."
}
keyform typelist
)
) )
(typecase-expected-type (keyclauselist)
`(OR ,@(mapcar #'first keyclauselist))
)
(case-errorstring (keyform keyclauselist)
(let ((caselist
(mapcap #'(lambda (keyclause)
(setq keyclause (car keyclause))
(if (listp keyclause) keyclause (list keyclause))
)
keyclauselist
)) )
(format nil
#L{
DEUTSCH "Der Wert von ~S muß einer der folgenden sein: ~{~S~^, ~}"
ENGLISH "The value of ~S must be one of ~{~S~^, ~}"
FRANCAIS "La valeur de ~S doit être l'une des suivantes : ~{~S~^, ~}"
}
keyform caselist
)
) )
(case-expected-type (keyclauselist)
`(MEMBER ,@(mapcap #'(lambda (keyclause)
(setq keyclause (car keyclause))
(if (listp keyclause) keyclause (list keyclause))
)
keyclauselist
) )
)
(simply-error (casename form clauselist errorstring expected-type)
(let ((var (gensym)))
`(LET ((,var ,form))
(,casename ,var
,@clauselist ; if a clause contains an OTHERWISE or T key,
; we could treat it specially or warn about it.
(OTHERWISE
(ERROR-OF-TYPE 'TYPE-ERROR
:DATUM ,var :EXPECTED-TYPE ',expected-type
#L{
DEUTSCH "~A~%Der Wert ist: ~S"
ENGLISH "~A~%The value is: ~S"
FRANCAIS "~A~%La valeur est : ~S"
}
,errorstring ,var
) ) ) )
) )
(retry-loop (casename place clauselist errorstring)
(let ((g (gensym))
(h (gensym)))
`(BLOCK ,g
(TAGBODY
,h
(RETURN-FROM ,g
(,casename ,place
,@clauselist ; if a clause contains an OTHERWISE or T key,
; we could treat it specially or warn about it.
(OTHERWISE
(RESTART-CASE
(PROGN ; no need for explicit association, see applicable-restart-p
(ERROR ; of-type ??
#L{
DEUTSCH "~A~%Der Wert ist: ~S"
ENGLISH "~A~%The value is: ~S"
FRANCAIS "~A~%La valeur est : ~S"
}
,errorstring
,place
) )
; only one restart, will "continue" invoke it?
(STORE-VALUE
:REPORT REPORT-NEW-VALUE
:INTERACTIVE (LAMBDA () (LIST (PROMPT-FOR-NEW-VALUE ',place)))
(NEW-VALUE) (SETF ,place NEW-VALUE)
) )
(GO ,h)
) ) ) ) )
)) )
(defmacro etypecase (keyform &rest keyclauselist)
(simply-error 'TYPECASE keyform keyclauselist
(typecase-errorstring keyform keyclauselist)
(typecase-expected-type keyclauselist)
) )
(defmacro ctypecase (keyplace &rest keyclauselist)
(retry-loop 'TYPECASE keyplace keyclauselist
(typecase-errorstring keyplace keyclauselist)
) )
(defmacro ecase (keyform &rest keyclauselist)
(simply-error 'CASE keyform keyclauselist
(case-errorstring keyform keyclauselist)
(case-expected-type keyclauselist)
) )
(defmacro ccase (keyform &rest keyclauselist)
(retry-loop 'CASE keyform keyclauselist
(case-errorstring keyform keyclauselist)
) )
)
;;; 29.4.11. Debugging Utilities
(defvar *debugger-hook* nil)
;; INVOKE-DEBUGGER, CLtL2 p. 915
; is in error.d
;; BREAK, CLtL2 p. 914
; (BREAK [format-string {arg}*])
; It would be unfair to bypass the *debugger-hook* test in INVOKE-DEBUGGER.
; So we call INVOKE-DEBUGGER and therefore need a condition.
(defun break (&optional (format-string "Break") &rest args)
(let ((condition
(make-condition 'simple-condition
:format-string format-string
:format-arguments args
)) )
(with-restarts
((CONTINUE
:report (lambda (stream)
(format stream
#L{
DEUTSCH "~S-Schleife beenden."
ENGLISH "Return from ~S loop"
FRANCAIS "Quitter le cycle de ~S."
}
'break
) )
()
))
(with-condition-restarts condition (list (find-restart 'CONTINUE))
(invoke-debugger condition)
) ) )
nil
)
;;; 29.4.1. Signaling Conditions
;; ERROR, CLtL2 p. 886
#| ; is in error.d
(defun error (errorstring &rest args)
(if (or *error-handler* (not *use-clcs*))
(progn
(if *error-handler*
(apply *error-handler* nil errorstring args)
(progn
(terpri *error-output*)
(write-string "*** - " *error-output*)
(apply #'format *error-output* errorstring args)
) )
(funcall *break-driver* nil)
)
(let ((condition (coerce-to-condition errorstring args 'error 'simple-error)))
(signal condition)
(invoke-debugger condition)
)
) )
|#
;; CERROR, CLtL2 p. 887
(defun cerror (continue-format-string error-format-string &rest args)
(if *error-handler*
(apply *error-handler*
(or continue-format-string t) error-format-string args
)
(if (not *use-clcs*)
(progn
(terpri *error-output*)
(write-string "** - Continuable Error" *error-output*)
(terpri *error-output*)
(apply #'format *error-output* error-format-string args)
(terpri *debug-io*)
(if (interactive-stream-p *debug-io*)
(progn
(write-string
#L{
DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
ENGLISH "If you continue (by typing 'continue'): "
FRANCAIS "Si vous continuez (en tapant 'continue'): "
}
*debug-io*
)
(apply #'format *debug-io* continue-format-string args)
(funcall *break-driver* t)
)
(apply #'format *debug-io* continue-format-string args)
) )
(let ((condition (coerce-to-condition error-format-string args 'cerror 'simple-error)))
(with-restarts
((CONTINUE
:report (lambda (stream)
(apply #'format stream continue-format-string args)
)
()
))
(with-condition-restarts condition (list (find-restart 'CONTINUE))
(signal condition)
(invoke-debugger condition)
) ) )
) )
nil
)
;;; 29.4.9. Warnings
;; WARN, CLtL2 p. 912
; (WARN format-string {arg}*)
(defun warn (format-string &rest args)
(if (not *use-clcs*)
(progn
(terpri *error-output*)
(write-string
#L{
DEUTSCH "WARNUNG:"
ENGLISH "WARNING:"
FRANCAIS "AVERTISSEMENT :"
}
*error-output*
)
(terpri *error-output*)
(apply #'format *error-output* format-string args)
(when *break-on-warnings* (funcall *break-driver* t))
)
(block warn
(let ((condition (coerce-to-condition format-string args 'warn 'simple-warning)))
(unless (typep condition 'warning)
(error-of-type 'type-error
:datum condition :expected-type 'warning
#L{
DEUTSCH "~S: Das ist ernster als eine Warnung: ~A"
ENGLISH "~S: This is more serious than a warning: ~A"
FRANCAIS "~S : C'est plus sérieux qu'un avertissement: ~A"
}
'warn condition
) )
(with-restarts
((MUFFLE-WARNING
() (return-from warn)
))
(with-condition-restarts condition (list (find-restart 'MUFFLE-WARNING))
(signal condition)
) )
(terpri *error-output*)
(write-string
#L{
DEUTSCH "WARNUNG:"
ENGLISH "WARNING:"
FRANCAIS "AVERTISSEMENT :"
}
*error-output*
)
(terpri *error-output*)
(print-condition condition *error-output*)
(when *break-on-warnings*
(with-restarts
((CONTINUE
:report (lambda (stream)
(format stream
#L{
DEUTSCH "~S-Schleife beenden."
ENGLISH "Return from ~S loop"
FRANCAIS "Quitter le cycle de ~S."
}
'break
) )
() (return-from warn)
))
(with-condition-restarts condition (list (find-restart 'CONTINUE))
; We don't call (invoke-debugger condition) because that
; would tell the user about a "Continuable error". Actually,
; it is only a warning!
(funcall *break-driver* nil condition nil)
) ) )
) )
)
nil
)
;; Bootstrapping done. Activate the Condition System.
(setq *use-clcs* t)
#|
Todo:
29.3.6 29.3.7 29.3.8 29.3.9 29.3.10
29.3.11 29.3.12 29.3.13 29.3.14 29.3.15 29.3.16 29.3.17 29.3.18
29.4. 29.4.9 29.4.11
29.5.
|#
;; Extensions. They assume *USE-CLCS* is T.
; (MUFFLE-CERRORS {form}*) executes the forms, but when a continuable
; error occurs, the CONTINUE restart is silently invoked.
(defmacro muffle-cerrors (&body body)
`(HANDLER-BIND ((ERROR #'(LAMBDA (CONDITION) (CONTINUE CONDITION))))
,@body
)
)
#| ; This works as well, but looks more like a hack.
(defmacro muffle-cerrors (&body body)
(let ((old-debugger-hook (gensym)))
`(LET* ((,old-debugger-hook *DEBUGGER-HOOK*)
(*DEBUGGER-HOOK*
#'(LAMBDA (CONDITION DEBUGGER-HOOK)
(CONTINUE CONDITION)
(WHEN ,old-debugger-hook
(FUNCALL ,old-debugger-hook CONDITION ,old-debugger-hook)
) )
))
(PROGN ,@body)
)
) )
|#
; (APPEASE-CERRORS {form}*) executes the forms, but turns continuable errors
; into warnings. A continuable error is signalled again as a warning, then
; its CONTINUE restart is invoked.
(defmacro appease-cerrors (&body body)
`(HANDLER-BIND ((ERROR #'(LAMBDA (CONDITION) (APPEASE-CERROR CONDITION))))
,@body
)
)
(defun appease-cerror (condition)
(let ((restart (find-restart 'CONTINUE condition)))
(when restart
(warn "~A" (with-output-to-string (stream)
(print-condition condition stream)
(let ((report-function (restart-report restart)))
(when report-function
(terpri stream)
(funcall report-function stream)
) ) ) )
(invoke-restart restart)
) ) )
; (EXIT-ON-ERROR {form}*) executes the forms, but exits Lisp if a
; non-continuable error occurs.
(defmacro exit-on-error (&body body)
`(HANDLER-BIND ((ERROR #'(LAMBDA (CONDITION) (EXITONERROR CONDITION))))
,@body
)
)
(defun exitonerror (condition)
(unless (find-restart 'CONTINUE condition)
(terpri *error-output*)
(write-string "*** - " *error-output*)
(print-condition condition *error-output*)
(exit t) ; exit Lisp with error
) )
; (SYSTEM::BATCHMODE-ERRORS {form}*) executes the forms, but handles errors
; just as a batch program should do: continuable errors are signalled as
; warnings, non-continuable errors cause Lisp to exit.
(defmacro batchmode-errors (&body body)
`(EXIT-ON-ERROR (APPEASE-CERRORS ,@body))
)