;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; 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
;;;
;;; **********************************************************************

(proclaim '(ignore ignore))

;;; 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.")


;;; *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*))

;;; 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 *break-prompt* "> " "Prompt string used in breakpoint loops.")
(proclaim '(special break-level))

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

(proclaim '(special *evalhook*))

(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
	  (*standard-input* *terminal-io*)
	  (*standard-output* *terminal-io*)
	  (*error-output* *terminal-io*)
	  (*query-io* *terminal-io*)
	  (*trace-output* *terminal-io*)
	  (* *) (** **) (*** ***)
	  (+ +) (++ ++) (+++ +++)
	  (/ /) (// //) (/// ///)
	  (*evalhook* ())
	  (*Error-cleanup-forms* ())
	  (break-level (if (and (boundp 'break-level)
				(numberp break-level))
			   (1+ break-level)
			   1)))
    LOOP
     (terpri)
     (princ break-level)
     (princ *break-prompt*)
     (catch 'break-loop-catcher 
      (setq +++ ++ ++ + + - - (Read))
      (cond ((and (consp -) (Eq (car -) 'Return))
	     (return (eval (cadr -))))
	    ;; These guys are escapes, not real $igns.
	    ;; but for VAX, accept dollars too (2nd case) %%%
	    ((memq - '(G $G)) (throw 'top-level-catcher ()))
	    ((memq - '(P $P)) (return ()))
	    (T (setq This-Eval (multiple-value-list (eval -)))
	       (Dolist (x this-eval) (print x))
	       (setq /// // // / / this-eval)
	       (setq *** ** ** * * (car This-Eval))))
      )
     (go loop))))

;;; Macros used by ferror & friends

;;; Find-name returns the name of a function if it is a subr or named-lambda.
;;;   If the function is a regular lambda, the whole list is returned, and if
;;;   the function can't be recognized, () is returned.
(defun find-name (function)
  (cond ((compiled-function-p function)
	 (%primitive header-ref function %function-name-slot))
	((not (consp function)) ())
	((eq (car function) 'Named-Lambda) (nth 1 function))
	((eq (car function) 'Lambda) function)
	(T ())))

;;; Get-caller returns a form that returns the function which called the
;;;   currently active function.
(defmacro get-caller ()
  '(read-cstack
    (%sp-make-fixnum
     (read-cstack (%sp-make-fixnum (%sp-current-stack-frame))
		  %frame-prev-active-slot))
    %frame-func-slot))



;;; Error-error can be called when the error system is in trouble and needs
;;;  to punt fast.  Prints a message without using format.  If we get into
;;;  this recursively, then halt.
(defvar %error-error-depth% 0)

(defun error-error (&rest messages)
  (prog ((%error-error-depth% (1+ %error-error-depth%)))
    (when (> %error-error-depth% 3)
      (%sp-halt)
      (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.

(defun signal (condition-name &rest args)
  "Finds a handler for condition-name, and calls it with same args as signal"

  ;;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))
;;; %sp-internal-error

;;; %SP-internal-error is called by the microcode when an internal error
;;;  occurrs.  It is simply a dispatch routine which looks up a specialized
;;;  function to call in the special variable, internal-error-table.
;;;
;;; Internal-error-table contains a vector, by error code, of functions which
;;;  take the caller's name, PC, ARG3, and ARG4 as arguments.  It is set up at 
;;;  system init time by the function internal-error-init.
;;;
;;; ERR-CODE -- a fixnum which identifies the specific error.
;;; PC -- the relative offset of the NEXT macro instruction to be
;;;        executed in the code vector of the errorful function.
;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE.

(proclaim '(special internal-error-table))

(defun %SP-internal-error (err-code PC &optional arg3 arg4)
  (infinite-error-protect
   (%sp-escape-return
    (funcall (%sp-v-access internal-error-table err-code)
	     (find-name (get-caller))
	     PC
	     arg3
	     arg4))))
;;; 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))))



;;; The common lisp ERROR function.

(defun error (control-string &rest args)
  "Signals a fatal error.  Control-string & args are formatted to *error-output*."
  (infinite-error-protect
   (error-body (find-name (get-caller)) ':error control-string args)))
;;; Cerror

(defun cerror (continue-format-string error-format-string &rest args)
  "Signals a continuable error.  See manual for details."
  (infinite-error-protect
   (let ((callers-name (find-name (get-caller))))
     (cerror-body callers-name
		  :error
		  error-format-string
		  continue-format-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.")

(defun warn (format-string &rest args)
  "Formats format-string & args to *error-output* as a warning message."
  (format *error-output*
	  (if *break-on-warnings*
	      "~%Warning-breakpoint in function ~s:~%"
	      "~%Warning in function ~s:~%")
	  (find-name (get-caller)))
  (apply #'format *error-output*
		  format-string
		  args)
  (when *break-on-warnings* (internal-break-loop))
  ())



(defun break (&optional format-string &rest args)
  "Formats format-string & args to *error-output & then enters break loop."
  (cond (format-string
	 (format *error-output* "~%Breakpoint:~%")
	 (apply #'format *error-output*
			 format-string
			 args))
	(T (format *error-output* "~%Breakpoint")))
  (internal-break-loop))
;;; Internal-error-table

;;; This function is called at init time to make the internal error table.
;;;  max-internal-error is defined in the init file.  The errors defined here
;;;  are common to both spice lisp and vax lisp.  Those errors which are
;;;  implementation specific are def-internal-errored in the init file.

(proclaim '(special allocation-space))

(defun make-error-table ()
  (setq internal-error-table
	(make-vector (1+ max-internal-error)
		     :initial-element
		     #'(lambda (&rest ignore) (break "Undefined Error."))))

  (def-internal-error 1 () system-error "Control Stack Overflow")
  (def-internal-error 2 () system-error "Control Stack Underflow")
  (def-internal-error 3 () system-error "Binding Stack Overflow")
  (def-internal-error 4 () system-error "Binding Stack Underflow")
  (def-internal-error 5 () system-error "Virtual Memory Overflow")
  (def-internal-error 8 () system-error "Illegal Effective Address")
  (def-internal-error 32 () system-error "Illegal Instruction")
  (def-internal-error 33 () system-error "Illegal Misc OP")
  (def-internal-error 42 () system-error "Null Open Frame" )
  (def-internal-error 43 () system-error "Undefined Type Code")
  (def-internal-error 44 () system-error "Return From Initial Function")
  (def-internal-error 45 () system-error "GC Forward Not To Newspace")
  (def-internal-error 46 () system-error "Attempt to Transport GC Forward")
  
  (def-internal-error 6 :unbound-variable fatal
    "Unbound symbol: ~s." arg3)
  (def-internal-error 7 :undefined-function fatal
    "Undefined function: ~s." arg3)

  (def-internal-error 12 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'character)
  (def-internal-error 13 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'System-Area-Pointer)
  (def-internal-error 14 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Control-Stack-Pointer)
  (def-internal-error 15 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Binding-Stack-Pointer)
  (def-internal-error 16 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Values-Marker)
  (def-internal-error 17 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Fixnum)
  (def-internal-error 18 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like)
  (def-internal-error 19 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like)
  (def-internal-error 20 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol)
  (def-internal-error 21 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Cons)
  (def-internal-error 22 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'List)
  (def-internal-error 23 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'String)
  (def-internal-error 24 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Number)
  (def-internal-error 25 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Misc-Type)
  (def-internal-error 26 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'U-Vector)
  (def-internal-error 47 :wrong-type-argument fatal
    "Wrong type argument, ~s, should be of type ~s." arg3 'integer)


  ;;Special because handlers won't work while allocation-space is wrong.
  (%sp-v-store internal-error-table
	       27
	       #'(lambda (callers-name ignore ignore ignore)
		   (let ((bazfaz allocation-space))
		     (setq allocation-space 0)
		     (error-body callers-name
				  :error
				  "Illegal allocation-space value: ~s."
				  (list bazfaz)))))

  (def-internal-error 9 :error fatal
    "Attempt to alter T or NIL.")
  (def-internal-error 11 :error fatal
    "Attempt to write to read only space. " )
  (def-internal-error 28 :error fatal
    "Illegal to allocate vector of size: ~s." arg3)
  (def-internal-error 29 :error fatal
    "Illegal immediate type code: ~s." arg3)
  (def-internal-error 30 :error fatal
    "Illegal control stack pointer: ~s." arg3)
  (def-internal-error 31 :error fatal
    "Illegal binding stack pointer: ~s." arg3)
  (def-internal-error 34 :error fatal
    "Attempt to divide ~s by ~s." arg4 arg3)
  (def-internal-error 35 :error fatal
    "Illegal u-vector access type: ~s." arg3)
  (def-internal-error 36 :error fatal
    "Vector index, ~s, out of bounds." arg3)
  (def-internal-error 37 :error fatal
    "Illegal byte pointer: (byte ~s ~s)." arg3 arg4)
  (def-internal-error 38 :invalid-function fatal
    "Invalid function: ~s." arg3)
  (def-internal-error 39 :too-few-arguments fatal
    "Too few arguments, ~s, for function, ~s." arg3 arg4)
  (def-internal-error 40 :too-many-arguments fatal
    "Too many arguments, ~s, for function, ~s." arg3 arg4)
  (def-internal-error 41 :unseen-throw-tag fatal
    "No catcher for throw tag ~s." arg3)
  (def-internal-error 48 :error fatal
    "Something using ~S and ~S lead to a short-float underflow." arg3 arg4)
  (def-internal-error 49 :error fatal
    "Something using ~S and ~S lead to a short-float overflow." arg3 arg4)
  (def-internal-error 50 :error fatal
    "Something using ~S and ~S lead to a long-float underflow." arg3 arg4)
  (def-internal-error 51 :error fatal
    "Something using ~S and ~S lead to a long-float overflow." arg3 arg4)

  (def-internal-error 52 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'Flonum)

  (def-internal-error 62 :wrong-type-argument fatal
    "Wrong type argument, ~S, should have been a non-negative fixnum." arg3)
  (def-internal-error 63 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
  (def-internal-error 53 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
  (def-internal-error 54 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been of type ~s." arg3 'integer-vector)
  (def-internal-error 55 :wrong-type-argument fatal
    "Wrong type argument, ~s, should have been a function or an array." arg3)
  (def-internal-error 56 :error fatal
    "The vectors ~S and ~S are not of the same length." arg3 arg4)
  (def-internal-error 57 :error fatal
    "The array ~S is not one dimensional." arg3)
  (def-internal-error 58 :error fatal
    "~S is not a stringlike thing." arg3)
  (def-internal-error 59 :error fatal
    "~S is not a rational number." arg3)
  (def-internal-error 60 :error fatal
    "BLT too hairy!")
  (def-internal-error 61 :error fatal
    "Attempt to execute a silly instruction."))

;;; 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 ()
  (make-error-table)

  (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)))