;;; **********************************************************************
;;; 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). 
;;; **********************************************************************
;;;
;;; Macros & declarations extracted from Errorfuns.slisp
;;;   Should be incorporated into the standard compiler.
;;;
;;; Written by Jim Large
;;;
;;; **********************************************************************

;;; condition-bind & condition-setq return forms which use this variable

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

;;; Condition-Bind

;;; a bind-spec is (cond-spec handler).
;;; a bind-form is (CONS 'condition-name handler)
;;; a cond-spec is condition name, or list of condition names.

(defmacro condition-bind (bindings &rest forms)
  "Eval forms under temporary new condition handlers.  See manual for details."
  ;;cdr down the bindings list & build a list of bind-forms which will eval to
  ;;new bindings for the condition-handler-bindings stack
  (do ((bind-specs bindings (cdr bind-specs))
       (bind-forms ())
       (cond-spec  ()))   ;referenced often

      ;;when done building bind-forms, return a let which binds the old stack,
      ;;pushes the results of the bind-forms on it, and evals the user forms.
      ((null bind-specs)
       `(let ((condition-handler-bindings
		   (list* ,@(nreverse bind-forms)
			  condition-handler-bindings)))
	  (declare (special condition-handler-bindings))
	  ,@forms))

    ;; LOOP BODY
    (setq cond-spec (caar bind-specs))

    ;;Condition names are quoted, so check the type now.  must be symbol,
    ;;or a list of symbols.  if not return form which signals error.
    (if (not (or (symbolp cond-spec)
		 (and (not (atom cond-spec))		;(not (atom foo)) works
		      (do ((name cond-spec (cdr name)))	;  in Slisp & Maclisp.
			  ((null name) 't)
			(if (not (symbolp (car name)))
			    (return ()))))))
	(return `(cerror ':wrong-type-argument
			 "bad condition spec ~s. should be symbol or list of symbols."
			,cond-spec)))

    ;;now build a bind-form for each condition-name in cond-spec
    (if (not (atom cond-spec))
	(do ((name cond-spec (cdr name)))
	    ((null name) ())
	  (push `(cons ',(car name) ,(nth 1 (car bind-specs))) bind-forms))
	(push `(cons ',cond-spec ,(nth 1 (car bind-specs))) bind-forms))))
;;; Condition-Psetq

;;; Condition-psetq is the same as condition-bind except that the bind-specs
;;; list is of the form (cond-spec handler cond-spec handler ... ), and the
;;; form returned is a setq, not a let.

(defmacro condition-psetq (&rest specs)
   "Establish new condition handlers for duration of active condition-bind."
  (if
   (oddp (length specs))
  `(cerror ':contradictory-arguments
	    "conditions and handlers must come in pairs.")

  (do ((bind-specs specs (cddr bind-specs))
       (bind-forms ())
       (cond-spec ()))

      ((atom bind-specs)				;Use list* here so if
       `(cdar (setq condition-handler-bindings		;a handler is unbound
		    (list* ,@(nreverse bind-forms)	;the whole form fails
			   condition-handler-bindings))))

    (setq cond-spec (nth 0 bind-specs))

    ;;Condition names are quoted, so check the type now.  must be symbol,
    ;;or a list of symbols.  if not return form which signals error.
    (if (not (or (symbolp cond-spec)
		 (and (not (atom cond-spec))		;(not (atom foo)) works
		      (do ((name cond-spec (cdr name)))	;  in Slisp & Maclisp.
			  ((null name) 't)
			(if (not (symbolp (car name)))
			    (return ()))))))
	(return `(cerror ':wrong-type-argument
			 "bad condition spec ~s. should be symbol or list of symbols."
			 cond-spec)))

    ;;now build a bind-form for each condition-name in cond-spec
    (if (not (atom cond-spec))
	(do ((name cond-spec (cdr name)))
	    ((null name) ())
	  (push `(cons ',(car name) ,(nth 1 bind-specs)) bind-forms))
	(push `(cons ',cond-spec ,(nth 1 bind-specs)) bind-forms)))))
;;; Condition-Case

;;; returns a form which does the following:
;;; - condition-binds all of the named conditions to #'condition-case-handler.
;;;    condition-case-handler handles any condition by leaving the condition's
;;;    name in the special, handler-finger-print, and throwing to the catch
;;;    tag condition-case.
;;; - evaluates the form while catching condition-case
;;; - if handler-finger-print has been touched use it as the case key.
;;;    otherwise return all the values returned by form.
(defmacro condition-case (form &rest clauses)
  (do ((clauzez clauses (cdr clauzez))
       (bindings-list () (append bindings-list
				 (make-handler-bindings (caar clauzez)))))
      ((null clauzez)
       `(let* ((condition-handler-bindings
		(nconc ,bindings-list condition-handler-bindings))
	       (handler-finger-print ())
	       (results (multiple-value-list (catch 'condition-case ,form))))
	  (declare (special condition-handler-bindings))
	  (if handler-finger-print
	      (case handler-finger-print
		,@clauses)
	      (values-list results))))
    ))

;;; make-handler-bindings accepts a symbol or a list of symbols and returns
;;;  a list of forms (symbol . #'condition-case-handler), one for each symbol.
;;;  several of these lists can be appended to the condition-handler-binding
;;;  stack to form new condition bindings.
(eval-when (compile load eval)
  (defun make-handler-bindings (key-form)
    (do ((keys (if (listp key-form) key-form (list key-form)) (cdr keys))
	 (b-list () (cons
		     `(cons ,(car keys) #'condition-case-handler)
		     b-list)))
	((null keys) b-list)))
  )



(declare (special handler-finger-print))

(defun condition-case-handler (condition &rest ignore)
  (declare (ignore ignore))
  (setq handler-finger-print condition)
  (throw 'condition-case ()))
;;; Assert & check-type

(defvar *assertion-references* ()
  "A list of the REFERENCE args to the current failed assertion.")

(defvar *assertion-test* ()
  "The test form in the current failed assertion.")

(defmacro assert (test &rest args)
  (do ((args args (cdr args)) 
       (references () (cons (car args) references)))
      ((or (null args) (stringp (car args)))
       (let ((format-string (car args))
	     (format-args (cdr args))
	     (references (reverse references)))
	 `(PROG ((*ASSERTION-REFERENCES* ',references)
		 (*ASSERTION-TEST* ',test))
	    TOP
	    (IF ,test (RETURN ()))
	    (CERROR "Test the assertion again."
		    ,(if format-string format-string "Failed assertion.")
		    ,@format-args)
	    (GO TOP))))))



(defmacro check-type (place typespec &optional string)
  `(PROG ()
     TOP
     (IF (TYPEP ,place ',typespec) (RETURN T))
     (CERROR "Prompt for a value to use."
	     "~s should hold an object of type ~a."
	     ',place
	     ,(if string string `(quote ,typespec)))
     (FORMAT *QUERY-IO*
	     "~%Give a value of type ~a for ~s: "
	     ,(if string string `(quote ,typespec))
	     ',place)
     (SETF ,place (EVAL (READ *QUERY-IO*)))
     (GO TOP)
     ))
;;; Def-Internal-Error

;;; Def-internal-error defines a form which can be put into the system init
;;;  file (spinit, or vaxinit) to define the errors which the microcode may
;;;  signal.  The form looks like
;;;
;;; (def-internal-error err-code condition flag control-string &rest args)
;;;  ERR-CODE -- the internal code for this error. less than or equal to
;;;               max-internal-error which is declared in the init file.
;;;  CONDITION -- the name of the error to signal
;;;  FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR.  (not evaluated)
;;;           if CORRECTABLE, %sp-internal-error may return correction values
;;;           if SYSTEM-ERROR, the CONDITION arg is ignored.
;;;  CONTROL-STRING -- the error message as a format control string.
;;;  ARGS -- The args to the control string.  The 3rd & 4th args to
;;;           %sp-internal-error are available as the variables ARG3 & ARG4.

;example
;  (def-internal-error 6 :unbound-symbol correctable
;    "Unbound symbol: ~s." arg3)

(declare (special internal-error-table))

(defmacro def-internal-error (number
 condition flag control-string &rest args)
  `(%sp-v-store
    internal-error-table
    ,number
    #'(lambda (callers-name ,(if (eq flag 'system-error) 'PC 'ignore)
			    ,(if (member 'arg3 args) 'arg3 'ignore)
			    ,(if (member 'arg4 args) 'arg4 'ignore))
	,(case flag
	   ((fatal) `(error-body callers-name
				  ,condition
				  ,control-string
				  (list ,@args)))
	   ((correctable) `(cerror-body callers-name
					,condition
					,control-string
					(list ,@args)))
	   ((system-error) 				     ;for system-error,
	    `(let ((*standard-output* *error-output*))	     ; we want to try
	       (Princ "Internal Error:
")							     ; right now!
	       (princ ,control-string )		             ;Lisp is probably
	       (princ " at byte ")			     ; already dead.
	       (princ PC)
	       (princ " in function ")
	       (princ callers-name)
	       (princ ".
")
	       (internal-break-loop)))
	   ))))


(defmacro errset (form flag)
  "Form flag
Maclisp errset.  Normally, the values from form are returned.  If an error 
occurs, then the error message is printed out (if flag is non-nil) and nil
is returned."
  `(catch 'catch-error
     (condition-bind
      ((:error (if ,flag #'(lambda (ignore continue-string function-name
					  error-string &rest args)
			     (Declare (ignore ignore))
			    (error-print error-string args function-name
					 continue-string)
			    (throw 'catch-error nil))
		   #'(lambda (&rest ignore)
		       (declare (ignore ignore))
		       (throw 'catch-error nil)))))
      ,form)))