archive/src/serror.lisp

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