Issue: ERROR-MACRO-MULTIPLE-EVALUATION (Version 1)

[Kent M Pitman <KMP@STONY-BROOK.SCRC.Symbolics.COM>]

I might allude to this at the meeting, but I don't expect a vote.
I'll send it out to X3J13 after we return from the meeting if there
are no comments, but feel free to suggest corrections/whatever.

-----
Issue:        ERROR-MACRO-MULTIPLE-EVALUATION
References:   Common Lisp Condition System, Revision 18
Category:     CHANGE
Edit history: 09-Oct-88, Version 1 by Pitman
Status:	      For Internal Discussion

Problem Description:

 CHECK-TYPE, ASSERT, CTYPECASE, and CCASE are permitted to do multiple
 evaluation of the respective place forms (or their subforms).

Proposal (ERROR-MACRO-MULTIPLE-EVALUATION:MAKE-SINGLE)

 Remove permission for the operators CHECK-TYPE, ASSERT, CTYPECASE, and
 CCASE to do multiple evaluation of their place forms.

Rationale:

 It's easy to implement single evaluation, and will lead to fewer
 puzzling effects.

Current Practice:

 Some implementations may already have fixed this `bug.'

Cost to Implementors:

 Very small.

 The following code, submitted by Kim A. Barrett at Integrated
 Inference Machines illustrates the fix:

 (defmacro CCASE (keyplace &rest clauses &environment env)
   (let ((keys (accumulate-cases 'ccase clauses nil))
	 (BLOCK (gensym))
	 (TAG (gensym)))
     (multiple-value-bind (vars vals stores setter getter)
	 (get-setf-method keyplace env)
       `(block ,BLOCK
	  (let* (,.(mapcar #'list vars vals)
		 (,(car stores) ,getter))
	    (tagbody
	     ,TAG
	     (return-from
	      ,BLOCK
	      (case ,(car stores)
		,@clauses
		(OTHERWISE
		 (restart-case (error 'case-failure
				      :name 'ccase
				      :datum ,(car stores)
				      :expected-type '(member ,@keys)
				      :possibilities ',keys)
		   (store-value (,(car stores))
		     :report (lambda (stream)
			       (format stream "Supply a new value for ~S."
				       ',keyplace))
		     :interactive read-evaluated-form
		     ,setter
		     (go ,TAG))))))))))))
 
 (defmacro CTYPECASE (keyplace &rest clauses &environment env)
   (let ((types (accumulate-cases 'ctypecase clauses t))
	 (BLOCK (gensym))
	 (TAG (gensym)))
     (multiple-value-bind (vars vals stores setter getter)
	 (get-setf-method keyplace env)
       `(block ,BLOCK
	  (let* (,.(mapcar #'list vars vals)
		 (,(car stores) ,getter))
	    (tagbody
	     ,TAG
	     (return-from
	      ,BLOCK
	      (typecase ,(car stores)
		,@clauses
		(OTHERWISE
		 (restart-case (error 'case-failure
				      :name 'ctypecase
				      :datum ,(car stores)
				      :expected-type '(or ,@types)
				      :possibilities ',types)
		   (store-value (,(car stores))
		     :report (lambda (stream)
			       (format stream "Supply a new value for ~S."
				       ',keyplace))
		     :interactive read-evaluated-form
		     ,setter
		     (go ,TAG))))))))))))
 
 (defmacro ASSERT (test-form &optional places datum &rest arguments
			     &environment env)
   (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)
		    (multiple-value-bind (vars vals stores setter getter)
			(get-setf-method place env)
		      `(let* (,.(mapcar #'list vars vals)
			      (,(car stores) (assert-prompt ',place ,getter)))
			 ,setter)))
		places)
	     (go ,TAG)))))))
 
 (defmacro CHECK-TYPE (place type &optional string &environment env)
   (let ((RETRY (gensym)))
     (multiple-value-bind (vars vals stores setter getter)
	 (get-setf-method place env)
       `(let* (,.(mapcar #'list vars vals)
	       (,(car stores) ,getter))
	  (tagbody
	   ,RETRY
	   (unless (typep ,(car stores) ',type) ;if typep is true, fall off end
	     (restart-case		       ; of tagbody, returning NIL
		(error 'simple-type-error
		       :datum ,(car stores)
		       :expected-type ',type
		       :format-string "The value of ~S is ~S, which is not ~@?."
		       :format-arguments
		       (list ',place ,(car stores)
			     ,@(if string
				   `("~A" ,string) ;in case string contains '~'
				   `("of type ~S" ',type))))
	      (store-value (,(car stores))
		:report (lambda (stream)
			  (format stream "Supply a new value for ~S." ',place))
		:interactive read-evaluated-form
		,setter
		(go ,RETRY)))))))))
Cost to Users:

 None. This change is upward compatible with the existing Condition System.

Cost of Non-Adoption:

 Occassional confusion. Possible lurking portability problems.

Benefits:

 Cost of non-adoption is avoided.

Aesthetics:

 Slightly improved.

Discussion:

 This change was proposed by Kim Barrett at IIM.
 Pitman did the formal writeup based on comments in private mail.

 Pitman supports the change.