;;; Condition System for CLISP ;;; David Gadbois 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 # (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)) )