diff --git a/src/CHANGELOG b/src/CHANGELOG index 04c72171c..addc0b06e 100755 --- a/src/CHANGELOG +++ b/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 *** diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e84bf694e..e1b3edf90 100755 --- a/src/c/symbols_list.h +++ b/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}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 4198589dd..b7e00fb07 100755 --- a/src/c/symbols_list2.h +++ b/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}}; diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 7414ded66..c51927cff 100644 --- a/src/clos/conditions.lsp +++ b/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 diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 018d1d134..4b9292cbd 100644 --- a/src/cmp/sysfun.lsp +++ b/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 diff --git a/src/lsp/assert.lsp b/src/lsp/assert.lsp index ce6d22594..23db6ac5f 100644 --- a/src/lsp/assert.lsp +++ b/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))