1 |
|
;;; -*- Mode:Lisp; Package:SERROR; Base:10; Syntax:COMMON-LISP -*- |
2 |
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
3 |
|
;;; ;;;;; |
4 |
|
;;; Copyright (c) 1985,86 by William Schelter,University of Texas ;;;;; |
5 |
|
;;; All rights reserved ;;;;; |
6 |
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
7 |
|
;(require "SLOOP") |
8 |
|
(in-package "SERROR" :use '("SLOOP" "LISP")) |
9 |
|
;(export '(def-error-type cond-error cond-any-error condition-case |
10 |
|
; error-name error-string error-continue-string error-format-args |
11 |
|
; ) "SERROR") |
12 |
|
;(provide "SERROR") |
13 |
|
|
14 |
|
(export '(def-error-type cond-error cond-any-error condition-case |
15 |
|
error-name error-string error-continue-string error-format-args |
16 |
|
) "SERROR") |
17 |
|
|
18 |
|
(eval-when (compile) |
19 |
|
(proclaim '(optimize (safety 2) (speed 2) (space 2)))) |
20 |
|
|
21 |
|
;;do (require "SERROR") |
22 |
|
;;(use-package "SERROR") |
23 |
|
|
24 |
|
;;This file contains two error catching facilities. One based on |
25 |
|
;;catch and throw, and the other which may involve a closure. The |
26 |
|
;;latter can be more costly for frequently executed forms, but has |
27 |
|
;;the advantage that errors which match none of the conditions |
28 |
|
;;will go into the regular error handler at the point in the stack where |
29 |
|
;;the error occurred. |
30 |
|
|
31 |
|
;;First we set up an error catching for a common lisp |
32 |
|
;;whose primitive error handler is called si:universal-error-handler (eg kcl). |
33 |
|
;;Namely if *catch-error* is not nil then that means |
34 |
|
;;there is a (catch ':any-error somewhere up the stack. |
35 |
|
;;it is thrown to, along with the condition. |
36 |
|
;;At the that point if the condition matches that of |
37 |
|
;;the catch, it stops there, |
38 |
|
;;otherwise if *catch-error* is still not nil repeat |
39 |
|
;;Sample interface |
40 |
|
|
41 |
|
;(defun te (n m) |
42 |
|
; (cond-error (er) (hairy-arithmetic m n) |
43 |
|
; ((and (= 0 n) (= 0 m))(format t "Hairy arithmetic doesn't like m=0=n") 58) |
44 |
|
; ((eql (error-condition-name er) :wrong-type-args)(format t "Bonus for wrong args") 50) |
45 |
|
; ((symbolp n)(and (numberp (symbol-value n))(format t "Had to eval n") (te m (symbol-value n))))) |
46 |
|
|
47 |
|
|
48 |
|
|
49 |
|
;;if none of the cond clauses hold, then we signal a regular error using |
50 |
|
;;the system error handler , unless there are more *catch-error*'s up |
51 |
|
;;the stack. Major defect: If none of the conditions hold, we will have |
52 |
|
;;to signal our real error up at the topmost *catch-error* so losing the possibility |
53 |
|
;;of proceeding. The alternative is to some how get the tests down to where |
54 |
|
;;we want them, but that seems to mean consing a closure, and keeping a |
55 |
|
;;stack of them. This is getting a little fancy. |
56 |
|
;;don't know how to get back (and anyway we have unwound by throwing). |
57 |
|
;;Major advantages: If there is no error, no closures are consed, and |
58 |
|
;;should be reasonably fast. |
59 |
|
|
60 |
|
|
61 |
|
|
62 |
|
;;****** Very system dependent. Redefine main error handler ****** |
63 |
|
(eval-when (load compile eval) |
64 |
|
#-kcl |
65 |
|
(defun si::universal-error-handler (&rest args) |
66 |
|
(format t "Calling orignal error handler ~a" args)) |
67 |
|
|
68 |
|
(defvar *error-handler-function* 'si::universal-error-handler) |
69 |
|
(or (get *error-handler-function* :old-definition) |
70 |
|
(setf (get *error-handler-function* :old-definition) |
71 |
|
(symbol-function *error-handler-function*))) |
72 |
|
) |
73 |
|
|
74 |
|
(defstruct (error-condition :named (:conc-name error-)) |
75 |
|
name |
76 |
|
string ;the format string given to error. |
77 |
|
function ;occurs inside here |
78 |
|
continue-string |
79 |
|
format-args |
80 |
|
error-handler-args) |
81 |
|
|
82 |
|
(defparameter *catch-error* nil "If t errors will throw to :any-error tag") |
83 |
|
(defparameter *disable-catch-error* nil "If t only regular error handler will be used") |
84 |
|
(defparameter *catch-error-stack* (make-array 30 :fill-pointer 0) "If t only regular error handler will be used") |
85 |
|
(defvar *show-all-debug-info* nil "Set to t if not |
86 |
|
running interactively") |
87 |
|
|
88 |
|
;;principal interfaces |
89 |
|
|
90 |
|
(defmacro cond-error (variables body-form &body clauses) |
91 |
|
"If a condition is signalled during evaluation of body-form, The first |
92 |
|
of VARIABLES is bound to the condition, and the clauses are evaluated |
93 |
|
like cond clauses. Note if the conditions involve lexical variables other than |
94 |
|
VARIABLES, there will be a new lexical closure cons'd each time through this!! |
95 |
|
eg: |
96 |
|
(cond-error (er) (1+ u) |
97 |
|
((null u) (princ er) (princ \"null arg to u\")) |
98 |
|
((symbolp u) (princ \"symbol arg\")) |
99 |
|
(t 0))" |
100 |
|
|
101 |
|
(or variables (setf variables '(ignore))) |
102 |
|
(let ((catch-tag (gensym "CATCH-TAG"))) |
103 |
|
(let ((bod `((catch ',catch-tag |
104 |
|
(return-from cond-error-continue |
105 |
|
(unwind-protect |
106 |
|
(progn |
107 |
|
(vector-push-extend |
108 |
|
#'(lambda ,variables ,(car variables) |
109 |
|
(if (or ,@ (mapcar 'car clauses)) ',catch-tag)) |
110 |
|
*catch-error-stack*) |
111 |
|
,body-form) |
112 |
|
(incf (the fixnum (fill-pointer *catch-error-stack*)) |
113 |
|
-1)))) |
114 |
|
(cond ,@ clauses |
115 |
|
(t (format t "should not get here") ))))) |
116 |
|
(cond (variables |
117 |
|
(setf bod |
118 |
|
` (multiple-value-bind |
119 |
|
,variables ,@ bod))) |
120 |
|
(t (setf bod (cons 'progn bod)))) |
121 |
|
`(block cond-error-continue ,bod)))) |
122 |
|
|
123 |
|
(defmacro cond-any-error (variables body-form &body clauses) |
124 |
|
"If a condition is signalled during evaluation of body-form, The first |
125 |
|
of VARIABLES is bound to the condition, and the clauses are evaluated |
126 |
|
like cond clauses, If the cond falls off the end, then the error is |
127 |
|
signaled at this point in the stack. For the moment the rest of the VARIABLES are ignored. |
128 |
|
eg: |
129 |
|
(cond-error (er) (1+ u) |
130 |
|
((null u) (princ er) (princ \"null arg to u\")) |
131 |
|
((symbolp u) (princ \"symbol arg\")) |
132 |
|
(t 0))" |
133 |
|
|
134 |
|
(let ((bod `( |
135 |
|
(let ((*catch-error* t)) |
136 |
|
(catch ':any-error |
137 |
|
(return-from cond-error-continue ,body-form))) |
138 |
|
(cond ,@ clauses |
139 |
|
(t (inf-signal ,@ variables)))))) |
140 |
|
(cond (variables |
141 |
|
(setf bod |
142 |
|
` (multiple-value-bind |
143 |
|
,variables ,@ bod))) |
144 |
|
(t (setf bod (cons 'progn bod)))) |
145 |
|
`(block cond-error-continue ,bod))) |
146 |
|
|
147 |
|
|
148 |
|
|
149 |
|
(defun #. (if (boundp '*error-handler-function*)*error-handler-function* 'joe) |
150 |
|
(&rest error-handler-args) |
151 |
|
(when *show-all-debug-info* |
152 |
|
(si::simple-backtrace)(si::backtrace) (si::break-vs)) |
153 |
|
(let ((err (make-error-condition |
154 |
|
:name (car error-handler-args) |
155 |
|
:string (fifth error-handler-args) |
156 |
|
:function (third error-handler-args) |
157 |
|
:continue-string (fourth error-handler-args) |
158 |
|
:format-args |
159 |
|
(copy-list (nthcdr 5 error-handler-args)) |
160 |
|
:error-handler-args (copy-list error-handler-args)))) |
161 |
|
(cond (*catch-error* (throw :any-error err)) |
162 |
|
((let (flag) (do ((i 0 (the fixnum (1+ i))) |
163 |
|
(end (the fixnum(fill-pointer (the array |
164 |
|
*catch-error-stack*))))) |
165 |
|
((>= i end)) |
166 |
|
(declare (fixnum i end)) |
167 |
|
(cond ((setq flag |
168 |
|
(funcall (aref *catch-error-stack* i) |
169 |
|
err)) |
170 |
|
(throw flag err)))))) |
171 |
|
(t (apply (get *error-handler-function* :old-definition) |
172 |
|
error-handler-args))))) |
173 |
|
|
174 |
|
(defun inf-signal (&rest error-handler-args) |
175 |
|
(apply *error-handler-function* |
176 |
|
(error-error-handler-args (car error-handler-args )))) |
177 |
|
|
178 |
|
#|Sample call |
179 |
|
(defun te (n) |
180 |
|
(cond-error (er) (progn (1+ n)) |
181 |
|
((null n) (print n) (print er) n) |
182 |
|
((symbolp n) (print n)))) |
183 |
|
|# |
184 |
|
|
185 |
|
(defmacro def-error-type (name (er) &body body) |
186 |
|
(let ((fname (intern (format nil "~a-tester" name)))) |
187 |
|
`(eval-when (compile eval load) |
188 |
|
(defun ,fname (,er) ,@ body) |
189 |
|
(deftype ,name ()`(and error-condition (satisfies ,',fname)))))) |
190 |
|
(def-error-type wta (er) (eql (error-name er) :wrong-type-arg)) |
191 |
|
|
192 |
|
#| |
193 |
|
(def-error-type hi-error (er) (eql (error-string er) "hi")) |
194 |
|
;this matches error signaled by (error "hi") or (cerror x "hi" ..) |
195 |
|
;can use the above so that the user can put |
196 |
|
(cond-error (er ) (hairy-stuff) |
197 |
|
((typep er 'wta) ...) |
198 |
|
((typep er '(or hi-error joe)) ...) |
199 |
|
(defun te2 (n) |
200 |
|
(sloop for i below n with x = 0 declare (fixnum x) |
201 |
|
do (cond-any-error (er) (setq x i) |
202 |
|
(t (print "hi"))))) |
203 |
|
|# |
204 |
|
;;In kcl cond-any-error is over 10 times as fast as cond-error, for the above. |
205 |
|
;;Note since t a clause we could have optimized to cond-any-error!! |
206 |
|
;;cond-error takes 1/1000 of second on sun 2 |
207 |
|
;;cond-any-error takes 1/10000 of second. (assuming no error!). |
208 |
|
|
209 |
|
|
210 |
|
(def-error-type subscript-out-of-bounds (er) |
211 |
|
#+ti (member 'si::subscript-out-of-bounds (funcall er :condition-names)) |
212 |
|
#+gcl(equal (error-string er) "The first index, ~S, to the array~%~S is too large.")) ;should collect all here |
213 |
|
(def-error-type ERROR (er) (eql (error-name er) :error)) |
214 |
|
(def-error-type WRONG-TYPE-ARGUMENT (er) (eql (error-name er) :WRONG-TYPE-ARGUMENT)) |
215 |
|
(def-error-type TOO-FEW-ARGUMENTS (er) (eql (error-name er) :TOO-FEW-ARGUMENTS)) |
216 |
|
(def-error-type TOO-MANY-ARGUMENTS (er) (eql (error-name er) :TOO-MANY-ARGUMENTS)) |
217 |
|
(def-error-type UNEXPECTED-KEYWORD (er) (eql (error-name er) :UNEXPECTED-KEYWORD)) |
218 |
|
(def-error-type INVALID-FORM (er) (eql (error-name er) :INVALID-FORM)) |
219 |
|
(def-error-type UNBOUND-VARIABLE (er) (eql (error-name er) :UNBOUND-VARIABLE)) |
220 |
|
(def-error-type INVALID-VARIABLE (er) (eql (error-name er) :INVALID-VARIABLE)) |
221 |
|
(def-error-type UNDEFINED-FUNCTION (er) (eql (error-name er) :UNDEFINED-FUNCTION)) |
222 |
|
(def-error-type INVALID-FUNCTION (er) (eql (error-name er) :INVALID-FUNCTION)) |
223 |
|
|
224 |
|
(defmacro condition-case (vars body-form &rest cases) |
225 |
|
(let ((er (car vars))) |
226 |
|
`(cond-error (,er) ,body-form |
227 |
|
,@ (sloop for v in cases |
228 |
|
when (listp (car v)) |
229 |
|
collecting `((typep ,er '(or ,@ (car v))),@ (cdr v)) |
230 |
|
else |
231 |
|
collecting `((typep ,er ',(car v)),@ (cdr v)))))) |
232 |
|
|
233 |
|
|