1 |
|
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- |
2 |
|
|
3 |
|
(IN-PACKAGE "CONDITIONS") |
4 |
|
|
5 |
|
(DEFVAR *HANDLER-CLUSTERS* NIL) |
6 |
|
|
7 |
|
(DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS) |
8 |
|
(UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS) |
9 |
|
(ERROR "Ill-formed handler bindings.")) |
10 |
|
`(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X))) |
11 |
|
BINDINGS)) |
12 |
|
*HANDLER-CLUSTERS*))) |
13 |
|
,@FORMS)) |
14 |
|
|
15 |
|
(DEFVAR *BREAK-ON-SIGNALS* NIL) |
16 |
|
|
17 |
|
(DEFUN SIGNAL (DATUM &REST ARGUMENTS) |
18 |
|
(LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL)) |
19 |
|
(*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*)) |
20 |
|
(IF (TYPEP CONDITION *BREAK-ON-SIGNALS*) |
21 |
|
(BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*." |
22 |
|
CONDITION)) |
23 |
|
(LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN)) |
24 |
|
(LET ((CLUSTER (POP *HANDLER-CLUSTERS*))) |
25 |
|
(DOLIST (HANDLER CLUSTER) |
26 |
|
(WHEN (TYPEP CONDITION (CAR HANDLER)) |
27 |
|
(FUNCALL (CDR HANDLER) CONDITION) |
28 |
|
(RETURN NIL) ;? |
29 |
|
)))) |
30 |
|
NIL)) |
31 |
|
|
32 |
|
;;; COERCE-TO-CONDITION |
33 |
|
;;; Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the |
34 |
|
;;; hairy argument conventions into a single argument that's directly usable |
35 |
|
;;; by all the other routines. |
36 |
|
|
37 |
|
(DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME) |
38 |
|
#+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS)) |
39 |
|
(COND ((CONDITIONP DATUM) |
40 |
|
(IF ARGUMENTS |
41 |
|
(CERROR "Ignore the additional arguments." |
42 |
|
'SIMPLE-TYPE-ERROR |
43 |
|
:DATUM ARGUMENTS |
44 |
|
:EXPECTED-TYPE 'NULL |
45 |
|
:FORMAT-STRING "You may not supply additional arguments ~ |
46 |
|
when giving ~S to ~S." |
47 |
|
:FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME))) |
48 |
|
DATUM) |
49 |
|
((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM)) |
50 |
|
(APPLY #'MAKE-CONDITION DATUM ARGUMENTS)) |
51 |
|
((STRINGP DATUM) |
52 |
|
(MAKE-CONDITION DEFAULT-TYPE |
53 |
|
:FORMAT-STRING DATUM |
54 |
|
:FORMAT-ARGUMENTS ARGUMENTS)) |
55 |
|
(T |
56 |
|
(ERROR 'SIMPLE-TYPE-ERROR |
57 |
|
:DATUM DATUM |
58 |
|
:EXPECTED-TYPE '(OR SYMBOL STRING) |
59 |
|
:FORMAT-STRING "Bad argument to ~S: ~S" |
60 |
|
:FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM))))) |
61 |
|
|
62 |
|
(DEFUN ERROR (DATUM &REST ARGUMENTS) |
63 |
|
(LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR))) |
64 |
|
(SIGNAL CONDITION) |
65 |
|
(INVOKE-DEBUGGER CONDITION))) |
66 |
|
|
67 |
|
(DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS) |
68 |
|
(WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS)) |
69 |
|
(APPLY #'ERROR DATUM ARGUMENTS)) |
70 |
|
NIL) |
71 |
|
|
72 |
|
(DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS) |
73 |
|
(WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.") |
74 |
|
(INVOKE-DEBUGGER |
75 |
|
(MAKE-CONDITION 'SIMPLE-CONDITION |
76 |
|
:FORMAT-STRING FORMAT-STRING |
77 |
|
:FORMAT-ARGUMENTS FORMAT-ARGUMENTS))) |
78 |
|
NIL) |
79 |
|
|
80 |
|
(DEFUN WARN (DATUM &REST ARGUMENTS) |
81 |
|
(LET ((CONDITION |
82 |
|
(COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN))) |
83 |
|
(CHECK-TYPE CONDITION WARNING "a warning condition") |
84 |
|
(IF *BREAK-ON-WARNINGS* |
85 |
|
(BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*." |
86 |
|
CONDITION)) |
87 |
|
(RESTART-CASE (SIGNAL CONDITION) |
88 |
|
(MUFFLE-WARNING () |
89 |
|
:REPORT "Skip warning." |
90 |
|
(RETURN-FROM WARN NIL))) |
91 |
|
(FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION) |
92 |
|
NIL)) |
93 |
|
|
94 |
|
(DEFMACRO HANDLER-CASE (FORM &REST CASES) |
95 |
|
(LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES))) |
96 |
|
(IF NO-ERROR-CLAUSE |
97 |
|
(LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN")) |
98 |
|
(ERROR-RETURN (MAKE-SYMBOL "ERROR-RETURN"))) |
99 |
|
`(BLOCK ,ERROR-RETURN |
100 |
|
(MULTIPLE-VALUE-CALL #'(LAMBDA ,@(CDR NO-ERROR-CLAUSE)) |
101 |
|
(BLOCK ,NORMAL-RETURN |
102 |
|
(RETURN-FROM ,ERROR-RETURN |
103 |
|
(HANDLER-CASE (RETURN-FROM ,NORMAL-RETURN ,FORM) |
104 |
|
,@(REMOVE NO-ERROR-CLAUSE CASES))))))) |
105 |
|
(LET ((TAG (GENSYM)) |
106 |
|
(VAR (GENSYM)) |
107 |
|
(ANNOTATED-CASES (MAPCAR #'(LAMBDA (CASE) (CONS (GENSYM) CASE)) |
108 |
|
CASES))) |
109 |
|
`(BLOCK ,TAG |
110 |
|
(LET ((,VAR NIL)) |
111 |
|
,VAR ;ignorable |
112 |
|
(TAGBODY |
113 |
|
(HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE) |
114 |
|
(LIST (CADR ANNOTATED-CASE) |
115 |
|
`#'(LAMBDA (TEMP) |
116 |
|
,@(IF (CADDR ANNOTATED-CASE) |
117 |
|
`((SETQ ,VAR TEMP))) |
118 |
|
(GO ,(CAR ANNOTATED-CASE))))) |
119 |
|
ANNOTATED-CASES) |
120 |
|
(RETURN-FROM ,TAG ,FORM)) |
121 |
|
,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE) |
122 |
|
(LIST (CAR ANNOTATED-CASE) |
123 |
|
(LET ((BODY (CDDDR ANNOTATED-CASE))) |
124 |
|
`(RETURN-FROM ,TAG |
125 |
|
,(COND ((CADDR ANNOTATED-CASE) |
126 |
|
`(LET ((,(CAADDR ANNOTATED-CASE) |
127 |
|
,VAR)) |
128 |
|
,@BODY)) |
129 |
|
((NOT (CDR BODY)) |
130 |
|
(CAR BODY)) |
131 |
|
(T |
132 |
|
`(PROGN ,@BODY))))))) |
133 |
|
ANNOTATED-CASES)))))))) |
134 |
|
|
135 |
|
(DEFMACRO IGNORE-ERRORS (&REST FORMS) |
136 |
|
`(HANDLER-CASE (PROGN ,@FORMS) |
137 |
|
(ERROR (CONDITION) (VALUES NIL CONDITION)))) |
138 |
|
|
139 |
|
;#+pcl |
140 |
|
;(defun conditions::find-class-no-error (object) |
141 |
|
; (ignore-errors (find-class object))) |
142 |
|
|