;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

(IN-PACKAGE "CONDITIONS")

(EVAL-WHEN (EVAL COMPILE LOAD)

(DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P)
  (DO ((L '())
       (C CASES (CDR C)))
      ((NULL C) (NREVERSE L))
    (LET ((KEYS (CAAR C)))
      (COND ((ATOM KEYS)
	     (COND ((NULL KEYS))
		   ((MEMBER KEYS '(OTHERWISE T))
		    (ERROR "OTHERWISE is not allowed in ~S expressions."
			   MACRO-NAME))
		   (T (PUSH KEYS L))))
	    (LIST-IS-ATOM-P
	     (PUSH KEYS L))
	    (T
	     (DOLIST (KEY KEYS) (PUSH KEY L)))))))

);NEHW-LAVE

(DEFMACRO ECASE (KEYFORM &REST CASES)
  (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL))
	(VAR (GENSYM)))
    `(LET ((,VAR ,KEYFORM))
       (CASE ,VAR
	 ,@CASES
	 (OTHERWISE
	   (ERROR 'CASE-FAILURE :NAME 'ECASE
		  		:DATUM ,VAR
				:EXPECTED-TYPE '(MEMBER ,@KEYS)
				:POSSIBILITIES ',KEYS))))))

(DEFMACRO CCASE (KEYPLACE &REST CASES)
  (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL))
	(TAG1 (GENSYM))
	(TAG2 (GENSYM)))
    `(BLOCK ,TAG1
       (TAGBODY ,TAG2
	 (RETURN-FROM ,TAG1
	   (CASE ,KEYPLACE
	     ,@CASES
	     (OTHERWISE
	       (RESTART-CASE (ERROR 'CASE-FAILURE
				    :NAME 'CCASE
				    :DATUM ,KEYPLACE
				    :EXPECTED-TYPE '(MEMBER ,@KEYS)
				    :POSSIBILITIES ',KEYS)
		 (STORE-VALUE (VALUE)
		     :REPORT (LAMBDA (STREAM)
			       (FORMAT STREAM "Supply a new value of ~S."
				       ',KEYPLACE))
		     :INTERACTIVE READ-EVALUATED-FORM
		   (SETF ,KEYPLACE VALUE)
		   (GO ,TAG2))))))))))

(DEFMACRO ETYPECASE (KEYFORM &REST CASES)
  (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T))
	(VAR (GENSYM)))
    `(LET ((,VAR ,KEYFORM))
       (TYPECASE ,VAR
	 ,@CASES
	 (OTHERWISE
	   (ERROR 'CASE-FAILURE :NAME 'ETYPECASE
		  		:DATUM ,VAR
				:EXPECTED-TYPE '(OR ,@TYPES)
				:POSSIBILITIES ',TYPES))))))

(DEFMACRO CTYPECASE (KEYPLACE &REST CASES)
  (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T))
	(TAG1 (GENSYM))
	(TAG2 (GENSYM)))
    `(BLOCK ,TAG1
       (TAGBODY ,TAG2
	 (RETURN-FROM ,TAG1
	   (TYPECASE ,KEYPLACE
	     ,@CASES
	     (OTHERWISE
	       (RESTART-CASE (ERROR 'CASE-FAILURE
				    :NAME 'CTYPECASE
				    :DATUM ,KEYPLACE
				    :EXPECTED-TYPE '(OR ,@TYPES)
				    :POSSIBILITIES ',TYPES)
		 (STORE-VALUE (VALUE)
		     :REPORT (LAMBDA (STREAM)
			       (FORMAT STREAM "Supply a new value of ~S."
				       ',KEYPLACE))
		     :INTERACTIVE READ-EVALUATED-FORM
		   (SETF ,KEYPLACE VALUE)
		   (GO ,TAG2))))))))))

(DEFUN ASSERT-REPORT (NAMES STREAM)
  (FORMAT STREAM "Retry assertion")
  (IF NAMES
      (FORMAT STREAM " with new value~P for ~{~S~^, ~}."
	      (LENGTH NAMES) NAMES)
      (FORMAT STREAM ".")))

(DEFUN ASSERT-PROMPT (NAME VALUE)
  (COND ((Y-OR-N-P "The old value of ~S is ~S.~
		  ~%Do you want to supply a new value? "
		   NAME VALUE)
	 (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")
	 (FLET ((READ-IT () (EVAL (READ *QUERY-IO*))))
	   (IF (SYMBOLP NAME) ;Help user debug lexical variables
	       (PROGV (LIST NAME) (LIST VALUE) (READ-IT))
	       (READ-IT))))
	(T VALUE)))

(DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION)
  (ERROR 'SIMPLE-TYPE-ERROR
	 :DATUM ASSERTION
	 :EXPECTED-TYPE NIL			; This needs some work in next revision. -kmp
	 :FORMAT-STRING "The assertion ~S failed."
	 :FORMAT-ARGUMENTS (LIST ASSERTION)))

(DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS)
  (LET ((TAG (GENSYM)))
    `(TAGBODY ,TAG
       (UNLESS ,TEST-FORM
	 (RESTART-CASE ,(IF DATUM
			    `(ERROR ,DATUM ,@ARGUMENTS)
			    `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM))
	   (CONTINUE ()
	       :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM))
	     ,@(MAPCAR #'(LAMBDA (PLACE)
			   `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE)))
		       PLACES)
             (GO ,TAG)))))))

(DEFUN READ-EVALUATED-FORM ()
  (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")
  (LIST (EVAL (READ *QUERY-IO*))))

(DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING)
  (LET ((TAG1 (GENSYM))
	(TAG2 (GENSYM)))
    `(BLOCK ,TAG1
       (TAGBODY ,TAG2
	 (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL))
	 (RESTART-CASE ,(IF TYPE-STRING
			    `(ERROR "The value of ~S is ~S, ~
				     which is not ~A."
				    ',PLACE ,PLACE ,TYPE-STRING)
			    `(ERROR "The value of ~S is ~S, ~
				     which is not of type ~S."
				    ',PLACE ,PLACE ',TYPE))
	   (STORE-VALUE (VALUE)
	       :REPORT (LAMBDA (STREAM)
			 (FORMAT STREAM "Supply a new value of ~S."
				 ',PLACE))
	       :INTERACTIVE READ-EVALUATED-FORM
	     (SETF ,PLACE VALUE)
	     (GO ,TAG2)))))))