Simplify ASSERT making it cheaper.

src/CHANGELOG

@@ -72,6 +72,9 @@ ECL 10.5.1:
    more precise type (fixnum, single-float, etc), when the iteration limits
    are known, as in (LOOP FOR I FROM 0 TO 1000 ....)
 
+ - ASSERT is now "cheaper", delegating the job on an auxiliary function and
+   not creating any nonlocal jump structures (TAGBODY, etc).
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/c/symbols_list.h

@@ -1921,5 +1921,7 @@ cl_symbols[] = {
 
 {EXT_ "COMPILER-TYPECASE", EXT_ORDINARY, NULL, -1, OBJNULL},
 
+{SYS_ "ASSERT-FAILURE", SI_ORDINARY, NULL, -1, OBJNULL},
+
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

src/c/symbols_list2.h

@@ -1921,5 +1921,7 @@ cl_symbols[] = {
 
 {EXT_ "COMPILER-TYPECASE",NULL},
 
+{SYS_ "ASSERT-FAILURE",NULL},
+
 /* Tag for end of list */
 {NULL,NULL}};

src/clos/conditions.lsp

@@ -724,6 +724,45 @@ memory limits before executing the program again."))))
   (let ((restart (find-restart 'USE-VALUE c)))
     (and restart (invoke-restart restart value))))
 
+(defun assert-report (names stream)
+  (declare (si::c-local))
+  (format stream "Retry assertion")
+  (if names
+      (format stream " with new value~P for ~{~S~^, ~}."
+	      (length names) names)
+      (format stream ".")))
+
+(defun assert-prompt (name value)
+  (declare (si::c-local))
+  (if (y-or-n-p "The old value of ~S is ~S.~
+		~%Do you want to supply a new value? "
+                name value)
+      (flet ((read-it () (eval (read *query-io*))))
+        (format *query-io* "~&Type a form to be evaluated:~%")
+        (if (symbolp name) ;Help user debug lexical variables
+            (progv (list name) (list value) (read-it))
+            (read-it)))
+      value))
+
+(defun assert-failure (test-form &optional place-names values
+                       &rest condition-arguments)
+  (unless arguments
+    (setf arguments (list 'SIMPLE-TYPE-ERROR
+			  :DATUM test-form
+			  :EXPECTED-TYPE nil ; This needs some work in revision
+			  :FORMAT-CONTROL "The assertion ~S failed"
+			  :FORMAT-ARGUMENTS (list test-form))))
+  (restart-case (error (si::coerce-to-condition (first arguments)
+						 (rest arguments)
+						 'simple-error
+						 'assert))
+    (continue ()
+      :REPORT (lambda (stream) (assert-report place-names stream))
+      (return-from assert-failure
+	(values-list (loop for place-name in place-names
+			for value in values
+			collect (assert-prompt place-name value)))))))
+
 ;;; ----------------------------------------------------------------------
 ;;; ECL's interface to the toplevel and debugger
 

src/cmp/sysfun.lsp

@@ -1010,6 +1010,7 @@
     si::structure-type-error si::define-structure
     si::coerce-to-list si::coerce-to-vector
     si::fill-array-with-seq
+    si::assert-failure
     #+formatter
     ,@'(
     format-princ format-prin1 format-print-named-character

src/lsp/assert.lsp

@@ -69,49 +69,22 @@ value is used to indicate the expected type in the error message."
 	   (go again)))))
   value)
 
-(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-CONTROL "The assertion ~S failed."
-	 :FORMAT-ARGUMENTS (list assertion)))
-
-(defmacro assert (test-form &optional places datum &rest arguments)
+(defmacro assert (test-form &optional places &rest arguments)
   "Args: (assert form [({place}*) [string {arg}*]])
 Evaluates FORM and signals a continuable error if the value is NIL.  Before
 continuing, receives new values of PLACEs from user.  Repeats this process
 until FORM returns a non-NIL value.  Returns NIL.  STRING is the format string
 for the error message and ARGs are arguments to the format string."
-  (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)))))))
+  (let ((repl
+         (if places
+             `(setf (values ,@places)
+                    (assert-failure ',test-form ',places (list ,@places)
+                                    ,@arguments))
+             `(assert-failure ',test-form
+                              ,@(and arguments
+                                     (list* nil nil arguments))))))
+  `(while (not ,test-form)
+     ,repl)))
 
 (defun accumulate-cases (macro-name cases list-is-atom-p)
   (declare (si::c-local))