;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: ("CONDITIONS" :USE "LISP" :SHADOW ("BREAK" "ERROR" "CERROR" "WARN" "CHECK-TYPE" "ASSERT" "ETYPECASE" "CTYPECASE" "ECASE" "CCASE")); Base: 10 -*- ;;; ;;; CONDITIONS ;;; ;;; This is a sample implementation. It is not in any way intended as the definition ;;; of any aspect of the condition system. It is simply an existence proof that the ;;; condition system can be implemented. ;;; ;;; While this written to be "portable", this is not a portable condition system ;;; in that loading this file will not redefine your condition system. Loading this ;;; file will define a bunch of functions which work like a condition system. Redefining ;;; existing condition systems is beyond the goal of this implementation attempt. (IN-PACKAGE "CONDITIONS" :USE '("LISP")) (SHADOW '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE)) (EXPORT '(;; Shadowed symbols BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE ;; New symbols *BREAK-ON-SIGNALS* *DEBUGGER-HOOK* SIGNAL HANDLER-CASE HANDLER-BIND IGNORE-ERRORS DEFINE-CONDITION MAKE-CONDITION WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND RESTART-NAME RESTART-NAME FIND-RESTART COMPUTE-RESTARTS INVOKE-RESTART INVOKE-RESTART-INTERACTIVELY ABORT CONTINUE MUFFLE-WARNING STORE-VALUE USE-VALUE INVOKE-DEBUGGER RESTART CONDITION WARNING SERIOUS-CONDITION SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-ERROR SIMPLE-CONDITION-FORMAT-STRING SIMPLE-CONDITION-FORMAT-ARGUMENTS STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED TYPE-ERROR TYPE-ERROR-DATUM TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR PROGRAM-ERROR CONTROL-ERROR STREAM-ERROR STREAM-ERROR-STREAM END-OF-FILE FILE-ERROR FILE-ERROR-PATHNAME CELL-ERROR UNBOUND-VARIABLE UNDEFINED-FUNCTION ARITHMETIC-ERROR ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS PACKAGE-ERROR PACKAGE-ERROR-PACKAGE DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW)) (EVAL-WHEN (EVAL COMPILE LOAD) (DEFVAR *THIS-PACKAGE* (FIND-PACKAGE "CONDITIONS")) );NEHW-LAVE ;;; Unique Ids (DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE)) (DEFVAR *UNIQUE-ID-COUNT* -1) (DEFUN UNIQUE-ID (OBJ) "Generates a unique integer ID for its argument." (OR (GETHASH OBJ *UNIQUE-ID-TABLE*) (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*)))) ;;; Miscellaneous Utilities (EVAL-WHEN (EVAL COMPILE LOAD) (DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS) (DO ((L LIST (CDDR L)) (K '() (LIST* (CADR L) (CAR L) K))) ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS))) (VALUES (NREVERSE K) L)))) (DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS) (LET ((TEMP (MEMBER '&REST NAMES))) (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is ~:[missing~;misplaced~]." TEMP)) (LET ((KEY-VARS (LDIFF NAMES TEMP)) (KEY-VAR (OR KEYWORDS-VAR (GENSYM))) (REST-VAR (CADR TEMP))) (LET ((KEYWORDS (MAPCAR #'(LAMBDA (X) (INTERN (STRING X) (FIND-PACKAGE "KEYWORD"))) KEY-VARS))) `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR) (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS) (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD))) KEY-VARS KEYWORDS) ,@FORMS)))))) );NEHW-LAVE ;;; Restarts (DEFVAR *RESTART-CLUSTERS* '()) (DEFUN COMPUTE-RESTARTS () (COPY-LIST (APPLY #'APPEND *RESTART-CLUSTERS*))) (DEFUN RESTART-PRINT (RESTART STREAM DEPTH) (DECLARE (IGNORE DEPTH)) (IF *PRINT-ESCAPE* (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART)) (RESTART-REPORT RESTART STREAM))) (DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT)) NAME FUNCTION REPORT-FUNCTION INTERACTIVE-FUNCTION) (DEFUN RESTART-REPORT (RESTART STREAM) (FUNCALL (OR (RESTART-REPORT-FUNCTION RESTART) (LET ((NAME (RESTART-NAME RESTART))) #'(LAMBDA (STREAM) (IF NAME (FORMAT STREAM "~S" NAME) (FORMAT STREAM "~S" RESTART))))) STREAM)) (DEFMACRO RESTART-BIND (BINDINGS &BODY FORMS) `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING) `(MAKE-RESTART :NAME ',(CAR BINDING) :FUNCTION ,(CADR BINDING) ,@(CDDR BINDING))) BINDINGS)) *RESTART-CLUSTERS*))) ,@FORMS)) (DEFUN FIND-RESTART (NAME) (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*) (DOLIST (RESTART RESTART-CLUSTER) (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) (RETURN-FROM FIND-RESTART RESTART))))) (DEFUN INVOKE-RESTART (RESTART &REST VALUES) (LET ((REAL-RESTART (OR (FIND-RESTART RESTART) (ERROR "Restart ~S is not active." RESTART)))) (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES))) (DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART) (LET ((REAL-RESTART (OR (FIND-RESTART RESTART) (ERROR "Restart ~S is not active." RESTART)))) (APPLY (RESTART-FUNCTION REAL-RESTART) (LET ((INTERACTIVE-FUNCTION (RESTART-INTERACTIVE-FUNCTION REAL-RESTART))) (IF INTERACTIVE-FUNCTION (FUNCALL INTERACTIVE-FUNCTION) '()))))) (DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES) (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE) (LET ((RESULT '())) (WHEN REPORT (SETQ RESULT (LIST* (IF (STRINGP REPORT) `#'(LAMBDA (STREAM) (WRITE-STRING ,REPORT STREAM)) `#',REPORT) :REPORT-FUNCTION RESULT))) (WHEN INTERACTIVE (SETQ RESULT (LIST* `#',INTERACTIVE :INTERACTIVE-FUNCTION RESULT))) (NREVERSE RESULT)))) (LET ((BLOCK-TAG (GENSYM)) (TEMP-VAR (GENSYM)) (DATA (MAPCAR #'(LAMBDA (CLAUSE) (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS) (CDDR CLAUSE)) (LIST (CAR CLAUSE) ;Name=0 (GENSYM) ;Tag=1 (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2 :INTERACTIVE INTERACTIVE) (CADR CLAUSE) ;BVL=3 FORMS))) ;Body=4 CLAUSES))) `(BLOCK ,BLOCK-TAG (LET ((,TEMP-VAR NIL)) (TAGBODY (RESTART-BIND ,(MAPCAR #'(LAMBDA (DATUM) (LET ((NAME (NTH 0 DATUM)) (TAG (NTH 1 DATUM)) (KEYS (NTH 2 DATUM))) `(,NAME #'(LAMBDA (&REST TEMP) #+LISPM (SETQ TEMP (COPY-LIST TEMP)) (SETQ ,TEMP-VAR TEMP) (GO ,TAG)) ,@KEYS))) DATA) (RETURN-FROM ,BLOCK-TAG ,EXPRESSION)) ,@(MAPCAN #'(LAMBDA (DATUM) (LET ((TAG (NTH 1 DATUM)) (BVL (NTH 3 DATUM)) (BODY (NTH 4 DATUM))) (LIST TAG `(RETURN-FROM ,BLOCK-TAG (APPLY #'(LAMBDA ,BVL ,@BODY) ,TEMP-VAR))))) DATA))))))) (DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-STRING &REST FORMAT-ARGUMENTS) &BODY FORMS) `(RESTART-CASE (PROGN ,@FORMS) (,RESTART-NAME () :REPORT (LAMBDA (STREAM) (FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS)) (VALUES NIL T)))) (DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH) DEPTH ;ignored (COND (*PRINT-ESCAPE* (FORMAT STREAM "#<~S.~D>" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION))) (T (CONDITION-REPORT CONDITION STREAM)))) (DEFSTRUCT (CONDITION :CONC-NAME (:CONSTRUCTOR |Constructor for CONDITION|) (:PREDICATE NIL) (:PRINT-FUNCTION CONDITION-PRINT)) (-DUMMY-SLOT- NIL)) (EVAL-WHEN (EVAL COMPILE LOAD) (DEFMACRO PARENT-TYPE (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE)) (DEFMACRO SLOTS (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS)) (DEFMACRO CONC-NAME (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME)) (DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION)) (DEFMACRO MAKE-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION)) );NEHW-LAVE (DEFUN CONDITION-REPORT (CONDITION STREAM) (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE))) ((NOT TYPE) (FORMAT STREAM "The condition ~A occurred.")) (LET ((REPORTER (REPORT-FUNCTION TYPE))) (WHEN REPORTER (FUNCALL REPORTER CONDITION STREAM) (RETURN NIL))))) (SETF (MAKE-FUNCTION 'CONDITION) '|Constructor for CONDITION|) (DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) (LET ((FN (MAKE-FUNCTION TYPE))) (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR :DATUM TYPE :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION) :FORMAT-STRING "Not a condition type: ~S" :FORMAT-ARGUMENTS (LIST TYPE))) (T (APPLY FN SLOT-INITIALIZATIONS))))) (EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time (DEFMACRO RESOLVE-FUNCTION (FUNCTION EXPRESSION RESOLVER) `(COND ((AND ,FUNCTION ,EXPRESSION) (CERROR "Use only the :~A information." "Only one of :~A and :~A is allowed." ',FUNCTION ',EXPRESSION)) (,EXPRESSION (SETQ ,FUNCTION ,RESOLVER)))) (DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE) (LET ((NEW '()) (USED '())) (DOLIST (SLOT SLOTS) (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE) (PUSH SLOT USED) (PUSH SLOT NEW))) (VALUES NEW USED))) (DEFUN SLOT-USED-P (SLOT-NAME TYPE) (COND ((EQ TYPE 'CONDITION) NIL) ((NOT TYPE) (ERROR "The type ~S does not inherit from CONDITION." TYPE)) ((ASSOC SLOT-NAME (SLOTS TYPE))) (T (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE))))) );NEHW-LAVE (DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS) (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT (INTERN (FORMAT NIL "Constructor for ~S" NAME))))) (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC) (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC)) SLOT-SPECS))) (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS) (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE) (LET ((CONC-NAME-P NIL) (CONC-NAME NIL) (REPORT-FUNCTION NIL) (DOCUMENTATION NIL)) (DO ((O OPTIONS (CDR O))) ((NULL O)) (LET ((OPTION (CAR O))) (CASE (CAR OPTION) ;Should be ECASE (:CONC-NAME (SETQ CONC-NAME-P T) (SETQ CONC-NAME (CADR OPTION))) (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION)) `(LAMBDA (STREAM) (WRITE-STRING ,(CADR OPTION) STREAM)) (CADR OPTION)))) (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION))) (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option." "Invalid DEFINE-CONDITION option: ~S" OPTION))))) (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" NAME) *PACKAGE*))) ;; The following three forms are compile-time side-effects. For now, they affect ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, ;; and CONC-NAME, the compiler could easily make them local. (SETF (PARENT-TYPE NAME) PARENT-TYPE) (SETF (SLOTS NAME) SLOTS) (SETF (CONC-NAME NAME) CONC-NAME) ;; Finally, the expansion ... `(PROGN (DEFSTRUCT (,NAME (:CONSTRUCTOR ,CONSTRUCTOR) (:PREDICATE NIL) (:COPIER NIL) (:PRINT-FUNCTION CONDITION-PRINT) (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS) (:CONC-NAME ,CONC-NAME)) ,@NEW-SLOTS) (SETF (DOCUMENTATION ',NAME 'TYPE) ',DOCUMENTATION) (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE) (SETF (SLOTS ',NAME) ',SLOTS) (SETF (CONC-NAME ',NAME) ',CONC-NAME) (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION)) (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR) ',NAME)))))) (EVAL-WHEN (EVAL COMPILE LOAD) (DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P) (DO ((L '()) (C CASES (CDR C))) ((NULL C) (NREVERSE L)) (LET ((KEYS (CAAR C))) (COND ((ATOM KEYS) (COND ((NULL KEYS)) ((MEMBER KEYS '(OTHERWISE T)) (ERROR "OTHERWISE is not allowed in ~S expressions." MACRO-NAME)) (T (PUSH KEYS L)))) (LIST-IS-ATOM-P (PUSH KEYS L)) (T (DOLIST (KEY KEYS) (PUSH KEY L))))))) );NEHW-LAVE (DEFMACRO ECASE (KEYFORM &REST CASES) (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL)) (VAR (GENSYM))) `(LET ((,VAR ,KEYFORM)) (CASE ,VAR ,@CASES (OTHERWISE (ERROR 'CASE-FAILURE :NAME 'ECASE :DATUM ,VAR :EXPECTED-TYPE '(MEMBER ,@KEYS) :POSSIBILITIES ',KEYS)))))) (DEFMACRO CCASE (KEYPLACE &REST CASES) (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL)) (TAG1 (GENSYM)) (TAG2 (GENSYM))) `(BLOCK ,TAG1 (TAGBODY ,TAG2 (RETURN-FROM ,TAG1 (CASE ,KEYPLACE ,@CASES (OTHERWISE (RESTART-CASE (ERROR 'CASE-FAILURE :NAME 'CCASE :DATUM ,KEYPLACE :EXPECTED-TYPE '(MEMBER ,@KEYS) :POSSIBILITIES ',KEYS) (STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Supply a new value of ~S." ',KEYPLACE)) :INTERACTIVE READ-EVALUATED-FORM (SETF ,KEYPLACE VALUE) (GO ,TAG2)))))))))) (DEFMACRO ETYPECASE (KEYFORM &REST CASES) (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T)) (VAR (GENSYM))) `(LET ((,VAR ,KEYFORM)) (TYPECASE ,VAR ,@CASES (OTHERWISE (ERROR 'CASE-FAILURE :NAME 'ETYPECASE :DATUM ,VAR :EXPECTED-TYPE '(OR ,@TYPES) :POSSIBILITIES ',TYPES)))))) (DEFMACRO CTYPECASE (KEYPLACE &REST CASES) (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T)) (TAG1 (GENSYM)) (TAG2 (GENSYM))) `(BLOCK ,TAG1 (TAGBODY ,TAG2 (RETURN-FROM ,TAG1 (TYPECASE ,KEYPLACE ,@CASES (OTHERWISE (RESTART-CASE (ERROR 'CASE-FAILURE :NAME 'CTYPECASE :DATUM ,KEYPLACE :EXPECTED-TYPE '(OR ,@TYPES) :POSSIBILITIES ',TYPES) (STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Supply a new value of ~S." ',KEYPLACE)) :INTERACTIVE READ-EVALUATED-FORM (SETF ,KEYPLACE VALUE) (GO ,TAG2)))))))))) (DEFUN ASSERT-REPORT (NAMES STREAM) (FORMAT STREAM "Retry assertion") (IF NAMES (FORMAT STREAM " with new value~P for ~{~S~^, ~}." (LENGTH NAMES) NAMES) (FORMAT STREAM "."))) (DEFUN ASSERT-PROMPT (NAME VALUE) (COND ((Y-OR-N-P "The old value of ~S is ~S.~ ~%Do you want to supply a new value? " NAME VALUE) (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%") (FLET ((READ-IT () (EVAL (READ *QUERY-IO*)))) (IF (SYMBOLP NAME) ;Help user debug lexical variables (PROGV (LIST NAME) (LIST VALUE) (READ-IT)) (READ-IT)))) (T VALUE))) (DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION) (ERROR 'SIMPLE-TYPE-ERROR :DATUM ASSERTION :EXPECTED-TYPE NIL ; This needs some work in next revision. -kmp :FORMAT-STRING "The assertion ~S failed." :FORMAT-ARGUMENTS (LIST ASSERTION))) (DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS) (LET ((TAG (GENSYM))) `(TAGBODY ,TAG (UNLESS ,TEST-FORM (RESTART-CASE ,(IF DATUM `(ERROR ,DATUM ,@ARGUMENTS) `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM)) (CONTINUE () :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM)) ,@(MAPCAR #'(LAMBDA (PLACE) `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE))) PLACES) (GO ,TAG))))))) (DEFUN READ-EVALUATED-FORM () (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%") (LIST (EVAL (READ *QUERY-IO*)))) (DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING) (LET ((TAG1 (GENSYM)) (TAG2 (GENSYM))) `(BLOCK ,TAG1 (TAGBODY ,TAG2 (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL)) (RESTART-CASE ,(IF TYPE-STRING `(ERROR "The value of ~S is ~S, ~ which is not ~A." ',PLACE ,PLACE ,TYPE-STRING) `(ERROR "The value of ~S is ~S, ~ which is not of type ~S." ',PLACE ,PLACE ',TYPE)) (STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Supply a new value of ~S." ',PLACE)) :INTERACTIVE READ-EVALUATED-FORM (SETF ,PLACE VALUE) (GO ,TAG2))))))) (DEFVAR *HANDLER-CLUSTERS* NIL) (DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS) (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS) (ERROR "Ill-formed handler bindings.")) `(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X))) BINDINGS)) *HANDLER-CLUSTERS*))) ,@FORMS)) (DEFVAR *BREAK-ON-SIGNALS* NIL) (DEFUN SIGNAL (DATUM &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL)) (*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*)) (IF (TYPEP CONDITION *BREAK-ON-SIGNALS*) (BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*." CONDITION)) (LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN)) (LET ((CLUSTER (POP *HANDLER-CLUSTERS*))) (DOLIST (HANDLER CLUSTER) (WHEN (TYPEP CONDITION (CAR HANDLER)) (FUNCALL (CDR HANDLER) CONDITION) (RETURN NIL) ;? )))) NIL)) ;;; COERCE-TO-CONDITION ;;; Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the ;;; hairy argument conventions into a single argument that's directly usable ;;; by all the other routines. (DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME) #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS)) (COND ((TYPEP DATUM 'CONDITION) (IF ARGUMENTS (CERROR "Ignore the additional arguments." 'SIMPLE-TYPE-ERROR :DATUM ARGUMENTS :EXPECTED-TYPE 'NULL :FORMAT-STRING "You may not supply additional arguments ~ when giving ~S to ~S." :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME))) DATUM) ((SYMBOLP DATUM) ;roughly, (SUBTYPEP DATUM 'CONDITION) (APPLY #'MAKE-CONDITION DATUM ARGUMENTS)) ((STRINGP DATUM) (MAKE-CONDITION DEFAULT-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGUMENTS)) (T (ERROR 'SIMPLE-TYPE-ERROR :DATUM DATUM :EXPECTED-TYPE '(OR SYMBOL STRING) :FORMAT-STRING "Bad argument to ~S: ~S" :FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM))))) (DEFUN ERROR (DATUM &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR))) (SIGNAL CONDITION) (INVOKE-DEBUGGER CONDITION))) (DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS) (WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS)) (APPLY #'ERROR DATUM ARGUMENTS)) NIL) (DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS) (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.") (INVOKE-DEBUGGER (MAKE-CONDITION 'SIMPLE-CONDITION :FORMAT-STRING FORMAT-STRING :FORMAT-ARGUMENTS FORMAT-ARGUMENTS))) NIL) (DEFINE-CONDITION WARNING (CONDITION) ()) (DEFUN WARN (DATUM &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN))) (CHECK-TYPE CONDITION WARNING "a warning condition") (IF *BREAK-ON-WARNINGS* (BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*." CONDITION)) (RESTART-CASE (SIGNAL CONDITION) (MUFFLE-WARNING () :REPORT "Skip warning." (RETURN-FROM WARN NIL))) (FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION) NIL)) (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) ()) (DEFINE-CONDITION ERROR (SERIOUS-CONDITION) ()) (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) (FORMAT-STRING (FORMAT-ARGUMENTS '())) (:CONC-NAME INTERNAL-SIMPLE-CONDITION-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-WARNING (WARNING) (FORMAT-STRING (FORMAT-ARGUMENTS '())) (:CONC-NAME INTERNAL-SIMPLE-WARNING-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-ERROR (ERROR) (FORMAT-STRING (FORMAT-ARGUMENTS '())) (:CONC-NAME INTERNAL-SIMPLE-ERROR-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) (DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) (DEFINE-CONDITION TYPE-ERROR (ERROR) (DATUM EXPECTED-TYPE)) (DEFINE-CONDITION SIMPLE-TYPE-ERROR (TYPE-ERROR) (FORMAT-STRING (FORMAT-ARGUMENTS '())) (:CONC-NAME INTERNAL-SIMPLE-TYPE-ERROR-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) (NAME POSSIBILITIES) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S." (TYPE-ERROR-DATUM CONDITION) (CASE-FAILURE-NAME CONDITION) (CASE-FAILURE-POSSIBILITIES CONDITION))))) (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (INTERNAL-SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (INTERNAL-SIMPLE-WARNING-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (INTERNAL-SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-ERROR (INTERNAL-SIMPLE-ERROR-FORMAT-STRING CONDITION)))) (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (INTERNAL-SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (INTERNAL-SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (INTERNAL-SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-ERROR (INTERNAL-SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)))) (DEFINE-CONDITION PROGRAM-ERROR (ERROR) ()) (DEFINE-CONDITION CONTROL-ERROR (ERROR) ()) (DEFINE-CONDITION STREAM-ERROR (ERROR) (STREAM)) (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) ()) (DEFINE-CONDITION FILE-ERROR (ERROR) (PATHNAME)) (DEFINE-CONDITION PACKAGE-ERROR (ERROR) (PATHNAME)) (DEFINE-CONDITION CELL-ERROR (ERROR) (NAME)) (DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION ARITHMETIC-ERROR (ERROR) (OPERATION OPERANDS)) (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) ()) (DEFMACRO HANDLER-CASE (FORM &REST CASES) (LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES))) (IF NO-ERROR-CLAUSE (LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN")) (ERROR-RETURN (MAKE-SYMBOL "ERROR-RETURN"))) `(BLOCK ,ERROR-RETURN (MULTIPLE-VALUE-CALL #'(LAMBDA ,@(CDR NO-ERROR-CLAUSE)) (BLOCK ,NORMAL-RETURN (RETURN-FROM ,ERROR-RETURN (HANDLER-CASE (RETURN-FROM ,NORMAL-RETURN ,FORM) ,@(REMOVE NO-ERROR-CLAUSE CASES))))))) (LET ((TAG (GENSYM)) (VAR (GENSYM)) (ANNOTATED-CASES (MAPCAR #'(LAMBDA (CASE) (CONS (GENSYM) CASE)) CASES))) `(BLOCK ,TAG (LET ((,VAR NIL)) ,VAR ;ignorable (TAGBODY (HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE) (LIST (CADR ANNOTATED-CASE) `#'(LAMBDA (TEMP) ,@(IF (CADDR ANNOTATED-CASE) `((SETQ ,VAR TEMP))) (GO ,(CAR ANNOTATED-CASE))))) ANNOTATED-CASES) (RETURN-FROM ,TAG ,FORM)) ,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE) (LIST (CAR ANNOTATED-CASE) (LET ((BODY (CDDDR ANNOTATED-CASE))) `(RETURN-FROM ,TAG ,(COND ((CADDR ANNOTATED-CASE) `(LET ((,(CAADDR ANNOTATED-CASE) ,VAR)) ,@BODY)) ((NOT (CDR BODY)) (CAR BODY)) (T `(PROGN ,@BODY))))))) ANNOTATED-CASES)))))))) (DEFMACRO IGNORE-ERRORS (&REST FORMS) `(HANDLER-CASE (PROGN ,@FORMS) (ERROR (CONDITION) (VALUES NIL CONDITION)))) (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () (:REPORT "Abort failed.")) (DEFUN ABORT () (INVOKE-RESTART 'ABORT) (ERROR 'ABORT-FAILURE)) (DEFUN CONTINUE () (INVOKE-RESTART 'CONTINUE)) (DEFUN MUFFLE-WARNING () (INVOKE-RESTART 'MUFFLE-WARNING)) (DEFUN STORE-VALUE (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE)) (DEFUN USE-VALUE (VALUE) (INVOKE-RESTART 'USE-VALUE VALUE)) (DEFVAR *DEBUG-LEVEL* 0) (DEFVAR *DEBUG-ABORT* NIL) (DEFVAR *DEBUG-CONTINUE* NIL) (DEFVAR *DEBUG-CONDITION* NIL) (DEFVAR *DEBUG-RESTARTS* NIL) (DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0) (DEFVAR *DEBUG-EVAL* 'EVAL) (DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES))) (DEFMACRO DEBUG-COMMAND (X) `(GET ,X 'DEBUG-COMMAND)) (DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT)) (DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY) `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY)) (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL)) ',NAME)) (DEFUN READ-DEBUG-COMMAND () (FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*) (COND ((CHAR= (PEEK-CHAR T) #\:) (WITH-INPUT-FROM-STRING (STREAM (READ-LINE)) (LET ((EOF (LIST NIL))) (DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD"))) (READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number. (READ STREAM NIL EOF)) (READ STREAM NIL EOF)) (L '() (CONS FORM L))) ((EQ FORM EOF) (NREVERSE L)))))) (T (LIST :EVAL (READ))))) (DEFINE-DEBUG-COMMAND :EVAL (FORM) (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM)))) (DEFINE-DEBUG-COMMAND :ABORT () (IF *DEBUG-ABORT* (INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*) (FORMAT T "~&There is no way to abort.~%"))) (DEFINE-DEBUG-COMMAND :CONTINUE () (IF *DEBUG-CONTINUE* (INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*) (FORMAT T "~&There is no way to continue.~%"))) (DEFINE-DEBUG-COMMAND :ERROR () (FORMAT T "~&~A~%" *DEBUG-CONDITION*)) (DEFINE-DEBUG-COMMAND :HELP () (FORMAT T "~&You are in a portable debugger.~ ~%Type a debugger command or a form to evaluate.~ ~%Commands are:~%") (SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16) (FORMAT T "~& :EVAL form Evaluate a form.~ ~% :HELP Show this text.~%") (IF *DEBUG-ABORT* (FORMAT T "~& :ABORT Exit by ABORT.~%")) (IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE Exit by CONTINUE.~%")) (FORMAT T "~& :ERROR Reprint error message.~%")) (DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*) (MAX *NUMBER-OF-DEBUG-RESTARTS*) TARGET-COLUMN) (UNLESS MAX (SETQ MAX (LENGTH RESTARTS))) (WHEN RESTARTS (DO ((W (IF TARGET-COLUMN (- TARGET-COLUMN 3) (CEILING (LOG MAX 10)))) (P RESTARTS (CDR P)) (I 0 (1+ I))) ((OR (NOT P) (= I MAX))) (FORMAT T "~& :~A " (LET ((S (FORMAT NIL "~D" (+ I 1)))) (WITH-OUTPUT-TO-STRING (STR) (FORMAT STR "~A" S) (DOTIMES (I (- W (LENGTH S))) (WRITE-CHAR #\Space STR))))) (IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) ")) (IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) ")) (FORMAT T "~A" (CAR P)) (FORMAT T "~%")))) (DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG))) (WHEN *DEBUGGER-HOOK* (LET ((HOOK *DEBUGGER-HOOK*) (*DEBUGGER-HOOK* NIL)) (FUNCALL HOOK CONDITION HOOK))) (STANDARD-DEBUGGER CONDITION))) (DEFUN STANDARD-DEBUGGER (CONDITION) (LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) (*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) (*DEBUG-ABORT* (FIND-RESTART 'ABORT)) (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) (IF (OR (NOT *DEBUG-CONTINUE*) (NOT (EQ *DEBUG-CONTINUE* C))) C NIL)) (LET ((C (IF *DEBUG-RESTARTS* (FIRST *DEBUG-RESTARTS*) NIL))) (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) (*DEBUG-CONDITION* CONDITION)) (FORMAT T "~&~A~%" CONDITION) (SHOW-RESTARTS) (DO ((COMMAND (READ-DEBUG-COMMAND) (READ-DEBUG-COMMAND))) (NIL) (EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*)))) (DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL) (WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL) (COND ((NOT CMD)) ((INTEGERP CMD) (COND ((AND (PLUSP CMD) (< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) (LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*))) (IF ARGS (APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS)) (INVOKE-RESTART-INTERACTIVELY RESTART)))) (T (FORMAT T "~&No such restart.")))) (T (LET ((FN (DEBUG-COMMAND CMD))) (IF FN (COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))) (FORMAT T "~&Too ~:[few~;many~] arguments to ~A." (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)) CMD)) (T (APPLY FN ARGS))) (FORMAT T "~&~S is not a debugger command.~%" CMD))))))) ;;;; Sample Use ;;; ;;; To install this condition system, you must make your evaluator call the ;;; functions above. To make it more useful, you should try to establish reasonable ;;; restarts. What follows is an illustration of how this might be done if your ;;; evaluator were actually written in Lisp. (Note: The evaluator shown is not ;;; following CL evaluation rules, but that's not relevant to the points we're trying ;;; to make here.) #|| (DEFUN PROMPT-FOR (TYPE &OPTIONAL PROMPT) (FLET ((TRY () (FORMAT T "~&~A? " (OR PROMPT TYPE)) (READ))) (DO ((ANS (TRY) (TRY))) ((TYPEP ANS TYPE) ANS) (FORMAT T "~&Wrong type of response -- wanted ~S~%" TYPE)))) (DEFUN MY-PROMPT-FOR-VALUE () (LIST (MY-EVAL (PROMPT-FOR T "Value")))) (DEFUN MY-REPL () (LET ((*DEBUG-EVAL* 'MY-EVAL) (*DEBUG-PRINT* 'MY-PRINT)) (DO ((FORM (PROMPT-FOR 'T "Eval") (PROMPT-FOR 'T "Eval"))) ((NOT FORM)) (WITH-SIMPLE-RESTART (ABORT "Return to MY-REPL toplevel.") (MY-PRINT (MULTIPLE-VALUE-LIST (MY-EVAL FORM))))))) (DEFUN MY-PRINT (VALUES) (FORMAT T "~{~&=> ~S~}" VALUES)) (DEFUN MY-APPLY (FN &REST ARGS) (IF (FUNCTIONP FN) (APPLY #'APPLY FN ARGS) (RESTART-CASE (ERROR "Invalid function: ~S" FN) (USE-VALUE (X) :REPORT "Use a different function." :INTERACTIVE MY-PROMPT-FOR-VALUE (APPLY #'MY-APPLY X ARGS))))) (DEFUN MY-EVAL (X) (COND ((NUMBERP X) X) ((SYMBOLP X) (MY-EVAL-SYMBOL X)) ((STRINGP X) X) ((ATOM X) (ERROR "Illegal form: ~S" X)) ((NOT (ATOM (CAR X))) (MY-APPLY (MY-EVAL (CAR X)) (MAPCAR #'MY-EVAL (CDR X)))) ((EQ (CAR X) 'LAMBDA) #'(LAMBDA (&REST ARGS) (MY-EVAL `(LET ,(MAPCAR #'LIST (CADR X) ARGS) ,@(CDDR X))))) ((MEMBER (CAR X) '(QUOTE FUNCTION)) (CADR X)) ((EQ (CAR X) 'SETQ) (SETF (SYMBOL-VALUE (CADR X)) (MY-EVAL (CADDR X)))) ((EQ (CAR X) 'DEFUN) (SETF (SYMBOL-FUNCTION (CADR X)) (MY-EVAL `(LAMBDA ,@(CDDR X))))) ((EQ (CAR X) 'IF) (IF (MY-EVAL (CADR X)) (MY-EVAL (CADDR X)) (MY-EVAL (CADDDR X)))) ((EQ (CAR X) 'LET) (PROGV (MAPCAR #'CAR (CADR X)) (MAPCAR #'MY-EVAL (MAPCAR #'CADR (CADR X))) (MY-EVAL `(PROGN ,@(CDDR X))))) ((EQ (CAR X) 'PROGN) (DO ((L (CDR X) (CDR L))) ((NOT (CDR L)) (MY-EVAL (CAR L))) (MY-EVAL (CAR L)))) ((NOT (SYMBOLP (CAR X))) (ERROR "Illegal form: ~S" X)) (T (MY-APPLY (MY-FEVAL-SYMBOL (CAR X)) (MAPCAR #'MY-EVAL (CDR X)))))) (DEFUN MY-EVAL-SYMBOL (X) (IF (BOUNDP X) (SYMBOL-VALUE X) (RESTART-CASE (ERROR 'UNBOUND-VARIABLE :NAME X) (USE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Specify another value of ~S to use this time." X)) :INTERACTIVE MY-PROMPT-FOR-VALUE VALUE) (NIL () :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Retry the SYMBOL-VALUE operation on ~S." X)) (MY-EVAL-SYMBOL X)) (MY-STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Specify another value of ~S to store and use." X)) :INTERACTIVE MY-PROMPT-FOR-VALUE (SETF (SYMBOL-VALUE X) VALUE) VALUE)))) (DEFUN MY-FEVAL-SYMBOL (X) (IF (FBOUNDP X) (SYMBOL-FUNCTION X) (RESTART-CASE (ERROR 'UNDEFINED-FUNCTION :NAME X) (USE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Specify a function to use instead of ~S this time." X)) :INTERACTIVE MY-PROMPT-FOR-VALUE VALUE) (NIL () :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Retry the SYMBOL-FUNCTION operation on ~S." X)) (MY-FEVAL-SYMBOL X)) (MY-STORE-VALUE (VALUE) :REPORT MY-PROMPT-FOR-VALUE (SETF (SYMBOL-FUNCTION X) VALUE) VALUE)))) ||# ;; End of sample application