* 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
is <function>eql</> to the old value. Conforming to this specification
is a nuisance when the "constant" value is only constant under some
weaker test like <function>string=</> or <function>equal</>. It's
-especially annoying because <function>defconstant</> takes effect
+especially annoying because, in &SBCL;, <function>defconstant</> takes effect
not only at load time but also at compile time, so that just
compiling and loading reasonable code like
<programlisting>(defconstant +foobyte+ '(1 4))</>
<function>defconstant</> either with <function>defparameter</> or
with a customized macro which does the right thing, possibly along the
lines of the <function>defconstant-eqx</> macro used internally in the
-implementation of SBCL itself.</para>
+implementation of &SBCL; itself. In circumstances where this is not
+appropriate, the programmer can handle the condition type
+<errortype>sb-ext:defconstant-uneql</errortype>, and choose either the
+<action>continue</action> or <action>abort</action> restart as
+appropriate.</para>
<para>&SBCL; gives style warnings about various kinds of perfectly
legal code, e.g.
;; 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"
;; 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
"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
;; 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"
(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
+ "~@<The constant ~S is being redefined (from ~S to ~S)~@:>"
+ (defconstant-uneql-name condition)
+ (defconstant-uneql-old-value condition)
+ (defconstant-uneql-new-value condition)))))
\f
;;;; special SBCL extension conditions
(tagbody
,@forms))))))
\f
+;;;; 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))))))))
+\f
;;;; miscellaneous
(defmacro-mundanely return (&optional (value nil))
(in-package "SB!KERNEL")
\f
-;;;; restarts
-
;;; a list of lists of restarts
(defvar *restart-clusters* '())
;;; 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)
(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
(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))))
\f
-;;;; 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))))
\f
-;;;; 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))))))))
-\f
+
;;;; helper functions for restartable error handling which couldn't be
;;;; defined 'til now 'cause they use the RESTART-CASE macro
;; 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.)
(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)
;;; 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"
projects / sbcl.git / commitdiff