/[gcl]/gcl/lsp/gcl_serror.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_serror.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
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                  

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26