;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (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 ((CONDITIONP DATUM) (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) ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM)) (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) (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)) (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))))