From d49c71bf00d858efc5796900ca4954fb76ce6402 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 5 Jun 2003 19:58:32 +0000 Subject: [PATCH] 0.8.0.37: Make DEFCONSTANT throw an error of type SB-EXT:DEFCONSTANT-UNEQL ... rearrange build order so that macros are defined at the birth of the cross-compiler (and that relevant variables are declared special) ... define the condition type (slots for OLD-VALUE, NEW-VALUE and NAME) ... actually throw the error in %DEFCONSTANT (and have an ABORT restart, too) ... document and test --- NEWS | 4 + doc/beyond-ansi.sgml | 8 +- package-data-list.lisp-expr | 19 +-- src/code/condition.lisp | 12 +- src/code/defboot.lisp | 268 +++++++++++++++++++++++++++++++++++++++++ src/code/target-error.lisp | 271 +----------------------------------------- src/compiler/defconstant.lisp | 13 +- tests/smoke.impure.lisp | 22 ++++ version.lisp-expr | 2 +- 9 files changed, 336 insertions(+), 283 deletions(-) diff --git a/NEWS b/NEWS index b9d65c3a6..773ddf2d1 100644 --- a/NEWS +++ b/NEWS @@ -1801,6 +1801,10 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: * increased compilation speed of long MULTIPLE-VALUES-BIND. * a contributed module implementing COMPILER-LET and MACROEXPAND-ALL has been included. + * DEFCONSTANT now throws a condition of type + SB-EXT:DEFCONSTANT-UNEQL if it is being asked to redefine a + constant to a non-EQL value; CONTINUE and ABORT restarts + respectively change and preserve the value. * fixed some bugs revealed by Paul Dietz' test suite: ** NIL is now allowed as a structure slot name. ** arbitrary numbers, not just reals, are allowed in certain diff --git a/doc/beyond-ansi.sgml b/doc/beyond-ansi.sgml index b1c0a39a3..1558f3ca4 100644 --- a/doc/beyond-ansi.sgml +++ b/doc/beyond-ansi.sgml @@ -48,7 +48,7 @@ of the same symbol more than once is undefined unless the new value is eql to the old value. Conforming to this specification is a nuisance when the "constant" value is only constant under some weaker test like string= or equal. It's -especially annoying because defconstant takes effect +especially annoying because, in &SBCL;, defconstant takes effect not only at load time but also at compile time, so that just compiling and loading reasonable code like (defconstant +foobyte+ '(1 4)) @@ -63,7 +63,11 @@ E.g., the code above can be given an exactly defined meaning by replacing defconstant either with defparameter or with a customized macro which does the right thing, possibly along the lines of the defconstant-eqx macro used internally in the -implementation of SBCL itself. +implementation of &SBCL; itself. In circumstances where this is not +appropriate, the programmer can handle the condition type +sb-ext:defconstant-uneql, and choose either the +continue or abort restart as +appropriate. &SBCL; gives style warnings about various kinds of perfectly legal code, e.g. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index e6ef8c6da..7f4ef67c6 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -499,12 +499,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; symbols in package COMMON-LISP. Lots of these symbols are accessed ;; with explicit SB!IMPL:: prefixes in the code. It would be nice to ;; reduce the use of this practice, so if symbols from here which are - ;; accessed that way are found to belong more appropriately in - ;; an existing package (e.g. KERNEL or SYS or EXT or FASL), I - ;; (WHN 19990223) encourage maintainers to move them there.. - ;; - ;; ..except that it's getting so big and crowded that maybe it should - ;; be split up, too. + ;; accessed that way are found to belong more appropriately in an + ;; existing package (e.g. SB!KERNEL or SB!SYS or SB!EXT or SB!FASL), + ;; I (WHN 19990223) encourage maintainers to move them there.. #s(sb-cold:package-data :name "SB!IMPL" :doc "private: a grab bag of implementation details" @@ -546,6 +543,11 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; error reporting, we have "DEFINE-SOURCE-CONTEXT" + ;; and given how many users dislike strict treatment of + ;; DEFCONSTANT, let's give them enough rope to escape by + "DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME" + "DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE" + ;; FIXME: This name doesn't match the DEFFOO - vs. - ;; DEFINE-FOO convention used in the ANSI spec, and so ;; was deprecated in sbcl-0.pre7, ca. 2001-12-12. After @@ -703,7 +705,7 @@ retained, possibly temporariliy, because it might be used internally." "SIMPLE-STYLE-WARNING" "SPECIAL-FORM-FUNCTION" "STYLE-WARN" - + ;; bootstrapping magic, to make things happen both in ;; the cross-compilation host compiler's environment and ;; in the cross-compiler's environment @@ -1371,9 +1373,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." ;; symbols from former SB!CONDITIONS "*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*" + "*CONDITION-RESTARTS*" "SHOW-CONDITION" "CASE-FAILURE" "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET" - "DESCRIBE-CONDITION" + "DESCRIBE-CONDITION" "MAKE-RESTART" "COERCE-TO-CONDITION" "CONDITION-READER-FUNCTION" "CONDITION-WRITER-FUNCTION" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 257360b37..0b2b49bcd 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -790,7 +790,17 @@ (define-condition sb!ext::timeout (serious-condition) ()) - +(define-condition defconstant-uneql (error) + ((name :initarg :name :reader defconstant-uneql-name) + (old-value :initarg :old-value :reader defconstant-uneql-old-value) + (new-value :initarg :new-value :reader defconstant-uneql-new-value)) + (:report + (lambda (condition stream) + (format stream + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition))))) ;;;; special SBCL extension conditions diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 8df43b2c2..45d064c79 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -319,6 +319,274 @@ (tagbody ,@forms)))))) +;;;; conditions, handlers, restarts + +;;; KLUDGE: we PROCLAIM these special here so that we can use restart +;;; macros in the compiler before the DEFVARs are compiled. +(sb!xc:proclaim + '(special *handler-clusters* *restart-clusters* *condition-restarts*)) + +(defmacro-mundanely with-condition-restarts + (condition-form restarts-form &body body) + #!+sb-doc + "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form* + Evaluates the Forms in a dynamic environment where the restarts in the list + Restarts-Form are associated with the condition returned by Condition-Form. + This allows FIND-RESTART, etc., to recognize restarts that are not related + to the error currently being debugged. See also RESTART-CASE." + (let ((n-cond (gensym))) + `(let ((*condition-restarts* + (cons (let ((,n-cond ,condition-form)) + (cons ,n-cond + (append ,restarts-form + (cdr (assoc ,n-cond *condition-restarts*))))) + *condition-restarts*))) + ,@body))) + +(defmacro-mundanely restart-bind (bindings &body forms) + #!+sb-doc + "Executes forms in a dynamic context where the given restart bindings are + in effect. Users probably want to use RESTART-CASE. When clauses contain + the same restart name, FIND-RESTART will find the first such clause." + `(let ((*restart-clusters* + (cons (list + ,@(mapcar (lambda (binding) + (unless (or (car binding) + (member :report-function + binding + :test #'eq)) + (warn "Unnamed restart does not have a ~ + report function: ~S" + binding)) + `(make-restart :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) + ,@forms)) + +;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if +;;; appropriate. Gross, but it's what the book seems to say... +(defun munge-restart-case-expression (expression env) + (let ((exp (sb!xc:macroexpand expression env))) + (if (consp exp) + (let* ((name (car exp)) + (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) + (if (member name '(signal error cerror warn)) + (once-only ((n-cond `(coerce-to-condition + ,(first args) + (list ,@(rest args)) + ',(case name + (warn 'simple-warning) + (signal 'simple-condition) + (t 'simple-error)) + ',name))) + `(with-condition-restarts + ,n-cond + (car *restart-clusters*) + ,(if (eq name 'cerror) + `(cerror ,(second expression) ,n-cond) + `(,name ,n-cond)))) + expression)) + expression))) + +;;; FIXME: I did a fair amount of rearrangement of this code in order to +;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested.. +(defmacro-mundanely restart-case (expression &body clauses &environment env) + #!+sb-doc + "(RESTART-CASE form + {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have special + meanings as points to which control may be transferred (see INVOKE-RESTART). + When clauses contain the same case-name, FIND-RESTART will find the first + such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or + macroexpands into such) then the signalled condition will be associated with + the new restarts." + (flet ((transform-keywords (&key report interactive test) + (let ((result '())) + (when report + (setq result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setq result (list* `#',interactive + :interactive-function + result))) + (when test + (setq result (list* `#',test :test-function result))) + (nreverse result))) + (parse-keyword-pairs (list keys) + (do ((l list (cddr l)) + (k '() (list* (cadr l) (car l) k))) + ((or (null l) (not (member (car l) keys))) + (values (nreverse k) l))))) + (let ((block-tag (gensym)) + (temp-var (gensym)) + (data + (macrolet (;; KLUDGE: This started as an old DEFMACRO + ;; WITH-KEYWORD-PAIRS general utility, which was used + ;; only in this one place in the code. It was translated + ;; literally into this MACROLET in order to avoid some + ;; cross-compilation bootstrap problems. It would almost + ;; certainly be clearer, and it would certainly be more + ;; concise, to do a more idiomatic translation, merging + ;; this with the TRANSFORM-KEYWORDS logic above. + ;; -- WHN 19990925 + (with-keyword-pairs ((names expression) &body forms) + (let ((temp (member '&rest names))) + (unless (= (length temp) 2) + (error "&REST keyword is ~:[missing~;misplaced~]." + temp)) + (let* ((key-vars (ldiff names temp)) + (keywords (mapcar #'keywordicate key-vars)) + (key-var (gensym)) + (rest-var (cadr temp))) + `(multiple-value-bind (,key-var ,rest-var) + (parse-keyword-pairs ,expression ',keywords) + (let ,(mapcar (lambda (var keyword) + `(,var (getf ,key-var + ,keyword))) + key-vars keywords) + ,@forms)))))) + (mapcar (lambda (clause) + (with-keyword-pairs ((report interactive test + &rest forms) + (cddr clause)) + (list (car clause) ;name=0 + (gensym) ;tag=1 + (transform-keywords :report report ;keywords=2 + :interactive interactive + :test test) + (cadr clause) ;bvl=3 + forms))) ;body=4 + clauses)))) + `(block ,block-tag + (let ((,temp-var nil)) + (tagbody + (restart-bind + ,(mapcar (lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setq ,temp-var temp) + (go ,tag)) + ,@keys))) + data) + (return-from ,block-tag + ,(munge-restart-case-expression expression env))) + ,@(mapcan (lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply (lambda ,bvl ,@body) + ,temp-var))))) + data))))))) + +(defmacro-mundanely with-simple-restart ((restart-name format-string + &rest format-arguments) + &body forms) + #!+sb-doc + "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) + body) + If restart-name is not invoked, then all values returned by forms are + returned. If control is transferred to this restart, it immediately + returns the values NIL and T." + `(restart-case + ;; If there's just one body form, then don't use PROGN. This allows + ;; RESTART-CASE to "see" calls to ERROR, etc. + ,(if (= (length forms) 1) (car forms) `(progn ,@forms)) + (,restart-name () + :report (lambda (stream) + (format stream ,format-string ,@format-arguments)) + (values nil t)))) + +(defmacro-mundanely handler-bind (bindings &body forms) + #!+sb-doc + "(HANDLER-BIND ( {(type handler)}* ) body) + Executes body in a dynamic context where the given handler bindings are + in effect. Each handler must take the condition being signalled as an + argument. The bindings are searched first to last in the event of a + signalled condition." + (let ((member-if (member-if (lambda (x) + (not (proper-list-of-length-p x 2))) + bindings))) + (when member-if + (error "ill-formed handler binding: ~S" (first member-if)))) + `(let ((*handler-clusters* + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + bindings)) + *handler-clusters*))) + (multiple-value-prog1 + (progn + ,@forms) + ;; Wait for any float exceptions. + #!+x86 (float-wait)))) + +(defmacro-mundanely handler-case (form &rest cases) + "(HANDLER-CASE form + { (type ([var]) body) }* ) + Execute FORM in a context with handlers established for the condition + types. A peculiar property allows type to be :NO-ERROR. If such a clause + occurs, and form returns normally, all its values are passed to this clause + as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one + var specification." + ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND + ;; and names for the subexpressions would make it easier to + ;; understand the code below. + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (make-symbol "normal-return")) + (error-return (make-symbol "error-return"))) + `(block ,error-return + (multiple-value-call (lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause cases))))))) + (let ((tag (gensym)) + (var (gensym)) + (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) + cases))) + `(block ,tag + (let ((,var nil)) + (declare (ignorable ,var)) + (tagbody + (handler-bind + ,(mapcar (lambda (annotated-case) + (list (cadr annotated-case) + `(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag + #!-x86 ,form + #!+x86 (multiple-value-prog1 ,form + ;; Need to catch FP errors here! + (float-wait)))) + ,@(mapcan + (lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from + ,tag + ,(cond ((caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body)) + ((not (cdr body)) + (car body)) + (t + `(progn ,@body))))))) + annotated-cases)))))))) + ;;;; miscellaneous (defmacro-mundanely return (&optional (value nil)) diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index f79f7bfc0..f4093cc4c 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -12,8 +12,6 @@ (in-package "SB!KERNEL") -;;;; restarts - ;;; a list of lists of restarts (defvar *restart-clusters* '()) @@ -21,6 +19,8 @@ ;;; associated with Condition (defvar *condition-restarts* ()) +(defvar *handler-clusters* nil) + (defstruct (restart (:copier nil) (:predicate nil)) (name (missing-arg) :type symbol :read-only t) (function (missing-arg) :type function) @@ -68,44 +68,6 @@ (format stream "~S" restart))))) stream)) -(defmacro with-condition-restarts (condition-form restarts-form &body body) - #!+sb-doc - "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form* - Evaluates the Forms in a dynamic environment where the restarts in the list - Restarts-Form are associated with the condition returned by Condition-Form. - This allows FIND-RESTART, etc., to recognize restarts that are not related - to the error currently being debugged. See also RESTART-CASE." - (let ((n-cond (gensym))) - `(let ((*condition-restarts* - (cons (let ((,n-cond ,condition-form)) - (cons ,n-cond - (append ,restarts-form - (cdr (assoc ,n-cond *condition-restarts*))))) - *condition-restarts*))) - ,@body))) - -(defmacro restart-bind (bindings &body forms) - #!+sb-doc - "Executes forms in a dynamic context where the given restart bindings are - in effect. Users probably want to use RESTART-CASE. When clauses contain - the same restart name, FIND-RESTART will find the first such clause." - `(let ((*restart-clusters* - (cons (list - ,@(mapcar (lambda (binding) - (unless (or (car binding) - (member :report-function - binding - :test #'eq)) - (warn "Unnamed restart does not have a ~ - report function: ~S" - binding)) - `(make-restart :name ',(car binding) - :function ,(cadr binding) - ,@(cddr binding))) - bindings)) - *restart-clusters*))) - ,@forms)) - (defun find-restart (name &optional condition) #!+sb-doc "Return the first restart named NAME. If NAME names a restart, the restart @@ -151,238 +113,11 @@ (let* ((real-restart (find-restart-or-lose restart)) (args (interactive-restart-arguments real-restart))) (apply (restart-function real-restart) args))) - -(eval-when (:compile-toplevel :load-toplevel :execute) -;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if -;;; appropriate. Gross, but it's what the book seems to say... -(defun munge-restart-case-expression (expression env) - (let ((exp (sb!xc:macroexpand expression env))) - (if (consp exp) - (let* ((name (car exp)) - (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) - (if (member name '(signal error cerror warn)) - (once-only ((n-cond `(coerce-to-condition - ,(first args) - (list ,@(rest args)) - ',(case name - (warn 'simple-warning) - (signal 'simple-condition) - (t 'simple-error)) - ',name))) - `(with-condition-restarts - ,n-cond - (car *restart-clusters*) - ,(if (eq name 'cerror) - `(cerror ,(second expression) ,n-cond) - `(,name ,n-cond)))) - expression)) - expression))) -) ; EVAL-WHEN - -;;; FIXME: I did a fair amount of rearrangement of this code in order to -;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested.. -(defmacro restart-case (expression &body clauses &environment env) - #!+sb-doc - "(RESTART-CASE form - {(case-name arg-list {keyword value}* body)}*) - The form is evaluated in a dynamic context where the clauses have special - meanings as points to which control may be transferred (see INVOKE-RESTART). - When clauses contain the same case-name, FIND-RESTART will find the first - such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or - macroexpands into such) then the signalled condition will be associated with - the new restarts." - (flet ((transform-keywords (&key report interactive test) - (let ((result '())) - (when report - (setq result (list* (if (stringp report) - `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - :report-function - result))) - (when interactive - (setq result (list* `#',interactive - :interactive-function - result))) - (when test - (setq result (list* `#',test :test-function result))) - (nreverse result))) - (parse-keyword-pairs (list keys) - (do ((l list (cddr l)) - (k '() (list* (cadr l) (car l) k))) - ((or (null l) (not (member (car l) keys))) - (values (nreverse k) l))))) - (let ((block-tag (gensym)) - (temp-var (gensym)) - (data - (macrolet (;; KLUDGE: This started as an old DEFMACRO - ;; WITH-KEYWORD-PAIRS general utility, which was used - ;; only in this one place in the code. It was translated - ;; literally into this MACROLET in order to avoid some - ;; cross-compilation bootstrap problems. It would almost - ;; certainly be clearer, and it would certainly be more - ;; concise, to do a more idiomatic translation, merging - ;; this with the TRANSFORM-KEYWORDS logic above. - ;; -- WHN 19990925 - (with-keyword-pairs ((names expression) &body forms) - (let ((temp (member '&rest names))) - (unless (= (length temp) 2) - (error "&REST keyword is ~:[missing~;misplaced~]." - temp)) - (let* ((key-vars (ldiff names temp)) - (keywords (mapcar #'keywordicate key-vars)) - (key-var (gensym)) - (rest-var (cadr temp))) - `(multiple-value-bind (,key-var ,rest-var) - (parse-keyword-pairs ,expression ',keywords) - (let ,(mapcar (lambda (var keyword) - `(,var (getf ,key-var - ,keyword))) - key-vars keywords) - ,@forms)))))) - (mapcar (lambda (clause) - (with-keyword-pairs ((report interactive test - &rest forms) - (cddr clause)) - (list (car clause) ;name=0 - (gensym) ;tag=1 - (transform-keywords :report report ;keywords=2 - :interactive interactive - :test test) - (cadr clause) ;bvl=3 - forms))) ;body=4 - clauses)))) - `(block ,block-tag - (let ((,temp-var nil)) - (tagbody - (restart-bind - ,(mapcar (lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setq ,temp-var temp) - (go ,tag)) - ,@keys))) - data) - (return-from ,block-tag - ,(munge-restart-case-expression expression env))) - ,@(mapcan (lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - (list tag - `(return-from ,block-tag - (apply (lambda ,bvl ,@body) - ,temp-var))))) - data))))))) - -(defmacro with-simple-restart ((restart-name format-string - &rest format-arguments) - &body forms) - #!+sb-doc - "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) - body) - If restart-name is not invoked, then all values returned by forms are - returned. If control is transferred to this restart, it immediately - returns the values NIL and T." - `(restart-case - ;; If there's just one body form, then don't use PROGN. This allows - ;; RESTART-CASE to "see" calls to ERROR, etc. - ,(if (= (length forms) 1) (car forms) `(progn ,@forms)) - (,restart-name () - :report (lambda (stream) - (format stream ,format-string ,@format-arguments)) - (values nil t)))) -;;;; HANDLER-BIND - -(defvar *handler-clusters* nil) - -(defmacro handler-bind (bindings &body forms) - #!+sb-doc - "(HANDLER-BIND ( {(type handler)}* ) body) - Executes body in a dynamic context where the given handler bindings are - in effect. Each handler must take the condition being signalled as an - argument. The bindings are searched first to last in the event of a - signalled condition." - (let ((member-if (member-if (lambda (x) - (not (proper-list-of-length-p x 2))) - bindings))) - (when member-if - (error "ill-formed handler binding: ~S" (first member-if)))) - `(let ((*handler-clusters* - (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - (multiple-value-prog1 - (progn - ,@forms) - ;; Wait for any float exceptions. - #!+x86 (float-wait)))) -;;;; HANDLER-CASE -(defmacro handler-case (form &rest cases) - "(HANDLER-CASE form - { (type ([var]) body) }* ) - Execute FORM in a context with handlers established for the condition - types. A peculiar property allows type to be :NO-ERROR. If such a clause - occurs, and form returns normally, all its values are passed to this clause - as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one - var specification." - ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND - ;; and names for the subexpressions would make it easier to - ;; understand the code below. - (let ((no-error-clause (assoc ':no-error cases))) - (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call (lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ,@(remove no-error-clause cases))))))) - (let ((tag (gensym)) - (var (gensym)) - (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) - cases))) - `(block ,tag - (let ((,var nil)) - (declare (ignorable ,var)) - (tagbody - (handler-bind - ,(mapcar (lambda (annotated-case) - (list (cadr annotated-case) - `(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag - #!-x86 ,form - #!+x86 (multiple-value-prog1 ,form - ;; Need to catch FP errors here! - (float-wait)))) - ,@(mapcan - (lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - ((not (cdr body)) - (car body)) - (t - `(progn ,@body))))))) - annotated-cases)))))))) - + ;;;; helper functions for restartable error handling which couldn't be ;;;; defined 'til now 'cause they use the RESTART-CASE macro diff --git a/src/compiler/defconstant.lisp b/src/compiler/defconstant.lisp index 3356b18c9..c70e9271e 100644 --- a/src/compiler/defconstant.lisp +++ b/src/compiler/defconstant.lisp @@ -40,9 +40,16 @@ the usual naming convention (names like *FOO*) for special variables" ;; is occasionally more appropriate). -- WHN 2001-12-21 (unless (eql value (info :variable :constant-value name)) - (cerror "Go ahead and change the value." - "The constant ~S is being redefined." - name))) + (multiple-value-bind (ignore aborted) + (with-simple-restart (abort "Keep the old value.") + (cerror "Go ahead and change the value." + 'defconstant-uneql + :name name + :old-value (info :variable :constant-value name) + :new-value value)) + (declare (ignore ignore)) + (when aborted + (return-from sb!c::%defconstant name))))) (:global ;; (This is OK -- undefined variables are of this kind. So we ;; don't warn or error or anything, just fall through.) diff --git a/tests/smoke.impure.lisp b/tests/smoke.impure.lisp index ee750cd6c..d5e86b3b8 100644 --- a/tests/smoke.impure.lisp +++ b/tests/smoke.impure.lisp @@ -37,5 +37,27 @@ (loop repeat 100000 do (profiled-fun)) (report) +;;; DEFCONSTANT should behave as the documentation specifies, +;;; including documented condition type. +(defun oidentity (x) x) +(defconstant +const+ 1) +(assert (= (oidentity +const+) 1)) +(let ((error (nth-value 1 (ignore-errors (defconstant +const+ 2))))) + (assert (typep error 'sb-ext:defconstant-uneql)) + (assert (= (sb-ext:defconstant-uneql-old-value error) 1)) + (assert (= (sb-ext:defconstant-uneql-new-value error) 2)) + (assert (eql (sb-ext:defconstant-uneql-name error) '+const+))) +(assert (= (oidentity +const+) 1)) +(handler-bind + ((sb-ext:defconstant-uneql + (lambda (c) (abort c)))) + (defconstant +const+ 3)) +(assert (= (oidentity +const+) 1)) +(handler-bind + ((sb-ext:defconstant-uneql + (lambda (c) (continue c)))) + (defconstant +const+ 3)) +(assert (= (oidentity +const+) 3)) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index eb59823f7..ae5efbc81 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.36" +"0.8.0.37" -- 2.11.4.GIT