Google
 

Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/error.clisp
There are no other files named error.clisp in the archive.
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Error handling functions for Spice Lisp.
;;;    these functions are part of the standard Spice Lisp environment.
;;;
;;; Written by Jim Large
;;; changes made by David McDonald and Walter van Roggen
;;;
;;; **********************************************************************

(in-package 'lisp)

(export '(*error-cleanup-forms* signal error cerror warn break
	  *break-on-warnings* *backtrace-print-length*
	  *backtrace-print-level*))

;;; Condition-handler-bindings is the binding stack which associates condition
;;;  names with handler functions.  It is a list of forms
;;;  (condition-name . handler-function) where condition name is a symbol, and
;;;  handler-function is a function object.

(defvar condition-handler-bindings ()
  "The binding stack where condition handlers are stored.")

;;; *break-entries* is a list of entry points to the break system.  
;;; The stack tracing functions use this to figure out the boundary
;;; between the break code and the user's code.

(defvar *break-entries* '(signal signal-cerror error cerror warn break))

;;; *Error-output* is the stream object which error messages are sent to.

(proclaim '(special *error-output*))

;;; (DILL  7/28/82) -- I put these in to make this compile with the
;;; new XC.

(proclaim '(special *query-io* *trace-output* *terminal-io*
		  *standard-output* *standard-input*))

(proclaim '(special pp-hash-table *pprint-recursive-call*))
;;; Break Loop

;;; All calls to this function should be through the break macro which is in
;;;  Error-macros.slisp, and is known to the compiler.
;;;
;;; The first thing internal-break-loop does is evaluate the forms in
;;;  *error-cleanup-forms* for side effects.  *error-cleanup-forms* is bound
;;;  to nil while this happens to prevent disaster.
;;;
;;; Then, we enter an REP loop which is like the top level loop except that
;;;  the standard streams are rebound to *terminal-io*,
;;;  + ++ & friends are bound to their present values,
;;;  *evalhook is BOUND to (),
;;;  *error-cleanup-forms* is bound to (),
;;;  A handler that throws back to the break loop is bound for all errors,
;;;  The symbols '$P and '$G and the form '(RETURN <form>) are all treated
;;;   specialy if they are typed in.

(defvar *error-cleanup-forms* ()
  "A list of forms which will be evaluated for side effect when break is
  called.")

(defvar *backtrace-print-length* 5
  "How many elements to print on each level during a backtrace.  Unlimited
  if null.")

(defvar *backtrace-print-level* 4
  "How many levels deep to print during a backtrace.  Unlimited if null.")

(defvar *break-prompt* "> " "Prompt string used in breakpoint loops.")

(proclaim '(special break-level))

(proclaim '(special - + ++ +++ * ** *** / // ///))

(proclaim '(special *evalhook*))

(defun dump-stack (error-level)
  (let ((sp (car error-level))
	(p (cdr error-level))
	item)
    (multiple-value-setq (sp p item)
      (nextbl sp p))
    (do ()
        ((null sp))
      (cond (p
	       (if (memq item '(speval sprevl)) (return-from dump-stack nil))
	       (terpri)
	       (prin1 sp)
	       (princ " compiled call to ")
	       (write item
		      :length *backtrace-print-length*
		      :level *backtrace-print-level*))
            ((and (listp (setq item (cdr item))) (eq (car item) 'block))
             (terpri)
	     (prin1 sp)
             (princ " ****** ")
             (write (cadr item)
		    :length *backtrace-print-length*
		    :level *backtrace-print-level*))
            (t
	       (if (memq item '(speval sprevl)) (return-from dump-stack nil))
	       (terpri)
	       (prin1 sp)
	       (princ " ")
               (write item
		      :length *backtrace-print-length*
		      :level *backtrace-print-level*)))
      (multiple-value-setq (sp p item)
        (nextbl sp p)))))

;;; Prettyprint current level only
(defun dump-stack-1 (error-level)
  (let ((sp (car error-level))
	(p (cdr error-level))
	(*print-pretty* t)
	item)
    (multiple-value-setq (sp p item)
      (nextbl sp p))
    (cond (p
	   (if (memq item '(speval sprevl)) (return-from dump-stack-1 nil))
	   (terpri)
	   (prin1 sp)
	   (princ " compiled call to ")
	   (format t "~S" item))
	  ((and (listp (setq item (cdr item))) (eq (car item) 'block))
	   (terpri)
	   (prin1 sp)
	   (princ " ****** ")
	   (format t "~S" (cadr item)))
	  (t
	   (if (memq item '(speval sprevl)) (return-from dump-stack-1 nil))
	   (terpri)
	   (prin1 sp)
	   (princ " ")
	   (format t "~S" item)))
    ))

;;; We have to look up the stack to figure out the break level.
;;; The obvious thing is to increment break-level each time we
;;; enter a break.  However because of the way we manipulate
;;; the SP context, this results in all levels looking like 1.

(defun get-break-level nil
   (do ((sp (spdlpt) (1- sp))
        (levels 0))
       ((eq sp 0) (1+ (/ levels 2)))
     (if (eq (spdlft sp) 'break-level)
	 (setq levels (1+ levels)))))


(defun internal-break-loop ()
  "Break loop.  But you should be using the Break function"

  (do ((*error-cleanup-forms* ())
       (e-forms *error-cleanup-forms* (cdr e-forms)))
      ((atom e-forms))
    (eval (car e-forms)))
  (clear-input *terminal-io*)

  (condition-bind ((() #'break-condition-handler))
   (prog (This-Eval
	  (error-level (get-error))
	  (*standard-input* *terminal-io*)
	  (*standard-output* *terminal-io*)
	  (*error-output* *terminal-io*)
	  (*query-io* *terminal-io*)
	  (*trace-output* *terminal-io*)
	  (* *) (** **) (*** ***)
	  (+ +) (++ ++) (+++ +++)
	  (/ /) (// //) (/// ///)
	  (*evalhook* ())
	  (*Error-cleanup-forms* ())
	  (? "You are in a breakpoint caused by an error.
The following special commands are available:

BK - show the active calls (the stack)
PP - prettyprint current stack level
^^ - return to top level
^  - exit from one level of break
OK - continue from the failed operation, using NIL
(OK <value>) - continue from the failed operation, using <value>
     [not needed for undefined function or var if you have defined it]
GO - retry the bad form. Hope you changed something so it works now
(RETURN <value>) - return value from bad form
<integer> - set context to specified level (-1 for level of error)

Anything else will be EVAL'ed as a Lisp form in the context 
of the error.")
	  (break-level (get-break-level)))
    LOOP
     (fresh-line)
     (princ break-level)
     (princ *break-prompt*)
     (catch 'break-loop-catcher 
      (setq +++ ++ ++ + + - - (Read))
      (cond ((integerp -)
	     (if (minusp -)
		 (setq error-level (get-error))
		 (setq error-level (cons - nil))))
	    ((and (consp -) (eq (car -) 'OK))
	     (return (speval (car error-level) (cadr -))))
	    ((and (consp -) (eq (car -) 'RETURN))
	     (sprevl (car error-level) (cadr -)))
	    ;; These guys are escapes, not real $igns.
	    ;; but for VAX, accept dollars too (2nd case) %%%
	    ((memq - '(^^ $G)) (throw 'top-level-catcher ()))
	    ((eq - '^))
	    ((memq - '(OK $P)) (return ()))
	    ((memq - '(BK $S)) (dump-stack error-level))
	    ((and (symbolp -)
		  (string-equal - 'PP)) (dump-stack-1 error-level))
	    ((eq - 'GO) (spredo (car error-level)))
	    ((eq - '?) (princ ?))
	    (T (setq This-Eval
                (multiple-value-list (speval (car error-level) -)))
	       (Dolist (x this-eval) (fresh-line) (prin1 x))
	       (terpri)
	       (setq /// // // / / this-eval)
	       (setq *** ** ** * * (car This-Eval))))
      )
     (when (eq - '^) (setq - nil) (throw 'break-loop-catcher nil))
     (go loop))))))

(defvar %error-error-depth% 0)

(defun error-error (&rest messages)
  (prog ((%error-error-depth% (1+ %error-error-depth%)))
    (when (> %error-error-depth% 3)
      (exit)
      (throw 'TOP-LEVEL-CATCHER ()))
    (dolist (item messages) (princ item *terminal-io*))
   REPEAT
    (internal-break-loop)
    (princ "Can't Proceed.")
    (go REPEAT)))



;;; infinite error protect is used by ferror & friends to keep lisp
;;;  out of hyperspace.

(defvar *max-error-depth* 3 "The maximum number of nested errors allowed.")
(defvar *current-error-depth* 0 "The current number of nested errors.")

(defmacro infinite-error-protect (&rest forms)
  `(let ((*current-error-depth* (1+ *current-error-depth*)))
     (if (> *current-error-depth* *max-error-depth*)
	 (error-error "Help! " *current-error-depth* " nested errors.")
	 ,@forms)))
;;; Signal

;;; (Signal condition-name args) searches for a handler which will handle
;;;  the condition condition-name.  Searches down the condition-handler-
;;;  bindings list for the first handler which is bound to condition-name,
;;;  and which will accept the call.  If none accept, return ().
;;;
;;; Handler is queried by calling it with all of the args to signal.  If it
;;;  returns nil, then it refuses.  Otherwise signal returns all of the
;;;  values returned by the handler.
;;;
;;; Condition-handler-bindings is a list of forms (name . function).
;;;
;;; Any handler for the condition () will be offered the chance to handle
;;;  any condition.  This feature is not part of common-lisp, but is useful
;;;  for the break loop which wants to catch all errors.

(eval-when (eval)
(defun signal (condition-name &rest args)
  "Finds a handler for condition-name, and calls it with same args as signal"
	(apply #'signal* condition-name args)))
)

(defun signal* (condition-name &rest args)
  (let ((pp-hash-table (make-hash-table :test #'eq))
	(*pprint-recursive-call* nil))
    ;;cdr down the list.  if we reach the end, return ().
    (do* ((bind-list condition-handler-bindings (cdr bind-list))
	  (binding (car bind-list) (car bind-list)))
	 ((null bind-list) ())
      ;;for each binding of the right condition, query & return values if win.
      (when (or (null (car binding))			;or the null condition.
		(eq (car binding) condition-name))
	(let ((result (multiple-value-list
		       (apply (cdr binding) condition-name args))))
	  (if (car result) (return (values-list result)))
	  ))
      )))
;;; Do-Failed-Handler

;;; Do-failed-handler is called by error, ferror, and %sp-internal-error
;;;  whenever a handler attempts to correct an uncorrectable error, or by
;;;  cerror whenever the handler returns something other than :return.
;;;  The args to do-failed-handler are exactly the args that were given to
;;;  the handler which failed, except that ARGS is not a rest arg.
;;;
;;; The control string we pass to the :failed-handler handler is pretty
;;;  hairy.  There are three cases of it so that the result will look
;;;  like the thing that signaled the error.

(defconstant error-style-failure-string
  "A handler for, ~s, tried to correct the uncorrectable error,~%~
     (error ~3g~@{ ~s~}),~%~
     which was originaly signaled in the function, ~2g~s.~%")

(defconstant cerror-style-failure-string
  "A handler for, ~s, failed to return, :return, while correcting the error,~%~
     (cerror ~0g~s~3g~@{ ~s~}),~%~
     which was originaly signaled in the function, ~2g~s.~%")


(defun do-failed-handler (condition correctablep callers-name
			  control-string args)
  (apply #'error
	 (cond (correctablep cerror-style-failure-string)
	       (t error-style-failure-string))
	 condition
	 ()
	 callers-name
	 control-string
	 args))
;;; Ferror (obsolete) & Error

;;; Error-body does the work of signaling a fatal error.  It is called from 
;;;  ERROR, and %SP-INTERNAL-ERROR.  It never returns.
;;;
;;; CALLERS-NAME	-- Name of user function that raised the error
;;; CONDITION		-- Name of condition to signal.
;;; CONTROL-STRING	-- format control string.
;;; ARGS		-- args for control-string.

(defun error-body (callers-name condition control-string args)
  (if (apply #'signal*
	     condition
	     ()	;null continue-string means not correctable error.
	     callers-name
	     control-string
	     args)
      (do-failed-handler condition () callers-name control-string args)
      (if (eq condition :error)
	  (error-error "No handler for condition, :error.")
	  (error-body callers-name :error control-string args))))


;get-caller attempts to find the name of the system routine that had
;problems.  

(defun get-caller nil
  (let* ((item (get-error))
	 (sp (car item))
	 (p (cdr item)))
;;since we are interpreted, many calls will generate funcall
    (if (and sp (not p) (eq (spdlrt sp) 'funcall))
	(multiple-value-setq (sp p item)
	    (nextbl sp p)))
;;if current thing is PUSHJ P,ERROR, we don't want to see "ERROR"
;;We have to find ERROR by using nextbl from slightly above,
;;since get-error only gives us the SP and P
    (when p
	(multiple-value-setq (sp p item)
	    (nextbl sp (1+ p)))
	(if (memq item *break-entries*)
	    (multiple-value-setq (sp p item)
		(nextbl sp p))))
;;Now use what we have
    (cond ((not sp) nil)
	  (p item)
	  ((speval sp '(boundp '%benv%))
	   (car (last (speval sp '%benv%)))))))

;;; get-error attempts to find sp and p values to use as the context
;;; for the break loop.
;;;
;;; We find the first blip beyond the error system, and use its sp,p.
;;; The problem with this is that it may leave the user in the middle
;;; of system code.  I have thought of all sorts of heuristics, and
;;; not come up with anything that can predict where the user is going
;;; to want to debug.  Let him set the context himself if he doesn't
;;; like this...

(defun get-error nil
  (let ((sp (spdlpt))
        (p nil)
        item)
    (multiple-value-setq (sp p item)
      (nextbl sp p))
    (do ()
        ((and (not p)
	      (listp (cdr item))
	      (eq (cadr item) 'block)
	      (memq (caddr item) *break-entries*)))
      (multiple-value-setq (sp p item)
         (nextbl sp p))
      (if (not sp)
	  (return-from get-error nil)))
;; We now have the block for the entry to the break system.
;; The next call is what we want
    (multiple-value-setq (sp p item)
      (nextbl sp p))
    (if sp
	(cons sp p)
	nil)))

;;; The common lisp ERROR function.

(eval-when (eval)
(defun error (control-string &rest args)
  "Signals a fatal error.  Control-string & args are formatted to
  *error-output*."
  (apply #'error* control-string args))
)

(defun error* (control-string &rest args)
  (let ((pp-hash-table (make-hash-table :test #'eq))
	(*pprint-recursive-call* nil))
    (infinite-error-protect
     (error-body (get-caller) ':error control-string args))))
;;; Cerror

(eval-when (eval)
(defun cerror (continue-format-string error-format-string &rest args)
  "Signals a continuable error.  See manual for details."
  (apply #'cerror* continue-format-string error-format-string args))
)

(defun cerror* (continue-format-string error-format-string &rest args)
  (let ((pp-hash-table (make-hash-table :test #'eq))
	(*pprint-recursive-call* nil))
    (infinite-error-protect
     (let ((callers-name (get-caller)))
       (cerror-body callers-name
		    :error
		    error-format-string
		    continue-format-string
		    args)))))


(eval-when (eval)
(defun signal-cerror (callers-name condition error-string continue-string args)
  (signal-cerror* callers-name condition error-string continue-string args))
)

(defun signal-cerror* (callers-name condition error-string continue-string
		       args)
  (declare (ignore callers-name))
  (let ((pp-hash-table (make-hash-table :test #'eq))
	(*pprint-recursive-call* nil))
    (infinite-error-protect
     (cerror-body (get-caller)
		  condition error-string continue-string args))))

;;; Cerror-body is an internal version of cerror which is called by CERROR,
;;; and %sp-internal-error.

(defun cerror-body (callers-name condition error-string continue-string args)
  (let ((result (multiple-value-list
		 (apply #'signal*
			condition
			continue-string
			callers-name
			error-string
			args))))
    (cond ((null (car result))
	   (if (eq condition :error)
	       (error-error "No handler for condition, :error.")
	       (cerror-body callers-name :error "Baz?" continue-string args)))
	  ((eq (car result) ':return)
	   (values-list (cdr result)))
	  (T
	   (do-failed-handler condition 'T callers-name continue-string args))
	  )))
;;; Warn & Break

(defvar *break-on-warnings* ()
  "If non-NIL, then WARN will enter a break loop before returning.")

(eval-when (eval)
(defun warn (format-string &rest args)
  "Formats format-string & args to *error-output* as a warning message."
  (apply #'warn* format-string args))
)

(defun warn* (format-string &rest args)
  (let ((pp-hash-table (make-hash-table :test #'eq))
	(*pprint-recursive-call* nil))
    (format *error-output*
	    (if *break-on-warnings*
		"~%Warning-breakpoint in function ~s:~%"
		"~%Warning in function ~s:~%")
	    (get-caller))
    (apply #'format *error-output*
	   format-string
	   args)
    (when *break-on-warnings* (internal-break-loop))
    ()))

(eval-when (eval)
(defun break (&optional format-string &rest args)
  "Formats format-string & args to *error-output* & then enters break loop."
  (apply 'break* format-string args))
)

(defun break* (&optional format-string &rest args)
  (let ((pp-hash-table (make-hash-table :test #'eq))
	(*pprint-recursive-call* nil))
    (cond (format-string
	   (format *error-output* "~%Breakpoint:~%")
	   (apply #'format *error-output*
		  format-string
		  args))
	  (T (format *error-output* "~%Breakpoint")))
    (internal-break-loop)))
;;; Error-Init

;;; Error-init is called at init time to initialize the error system.
;;;  it initializes the internal error table, and condition-psetq's the
;;;  error conditions which should always be present in the system.
;;;
;;; Only those error conditions which are common to both vax lisp and 
;;;  spice lisp are condition-psetq'd here.  Implementation specific
;;;  conditions are done in the init file.

(defun error-init ()

  (setq condition-handler-bindings ())   ;make sure it is empty.

  (condition-psetq
   :error #'default-condition-handler
   :unbound-variable #'default-unbound-variable-handler
   :undefined-function #'default-undefined-function-handler
   ))
;;; macros used by error handlers

;;; dont-proceed is the standard way to drop the user into a break loop
;;;  when we are handling a fatal error.

(defmacro dont-proceed ()
  '(prog ()
   foo
     (internal-break-loop)
     (warn "The current error is not correctable.")
     (go foo)))


;;; Error-Print formats an error message in the standard way.
(defun error-print (message args function continue-string)
  (format *error-output* "~%Error in function ~s.~%" function)
  (apply #'format *error-output* message args)
  (when continue-string
    (format *error-output* "~%If continued: ")
    (apply #'format *error-output* continue-string args)))
;;; Default-Condition-Handler & Break-Condition-Handler

;;; Default-condition-handler handles most of the conditions which are defined
;;;  in the Spice Lisp environment.  The handler prints a message, and enters
;;;  a break loop.  A default message is provided for each condition which
;;;  this handler will accept.

(defun default-condition-handler
  (ignore continue-string function-name error-string &rest args)
  (error-print error-string args function-name continue-string)
  (if continue-string
      (values ':return (internal-break-loop))
      (dont-proceed))
  )



;;; Break-condition-handler is a generic handler which will print a message,
;;;  and then punt back to the most recent break loop.  Break binds this to
;;;  unimportant conditions.

(defun break-condition-handler
  (ignore ignore ignore error-string &rest args)
  (apply #'format
	 *error-output*
	 error-string
	 args)
  (princ "
Error flushed.
" *error-output*)
  (throw 'break-loop-catcher ())
  )
;;; Default-Undefined-Function-Handler

;;; Default-undefined-function-handler is a handler for the :undefined-function
;;;  condition.  If the error is signaled correctably, then the correction
;;;  value is obtained by forcing the user to define the function in a
;;;  break-loop

(defun default-undefined-function-handler
  (ignore continue-string function error-string &rest args)

  (error-print error-string args function continue-string)
  (if continue-string
      (prog ()
       loop
	(internal-break-loop)
	(if (fboundp (car args))
	    (return (values ':return (symbol-function (car args)))))
	(format *error-output*
		"~%;Warning, Can not proceed until ~S has been defun'd."
		(car args))
	(go loop))
      ;; if not continue-string
      (dont-proceed)))
;;; Default-Unbound-Variable-Handler

;;; Default-unbound-variable handler is a handler for the :unbound-variable
;;;  condition.  If the error is signaled correctably, then the correction
;;;  value is obtained by forcing the user to setq the symbol in the
;;;  break loop.


(defun default-unbound-variable-handler
  (ignore continue-string function error-string &rest args)

  (error-print error-string args function continue-string)
  (if continue-string
      (prog ()
       loop
	(internal-break-loop)
	(if (boundp (car args))
	    (return (values ':return (symbol-value (car args)))))
	(format *error-output*
		"~%;Warning, Can not proceed until ~S has been Setq'd."
		(car args))
	(go loop))
      ;; if not continue-string
      (dont-proceed)))