Menu
▾
▴
[Sbcl-commits] master: Simplify MAKE-CONDITION, ALLOCATE-CONDITION.
|
From: Douglas K. <sn...@us...> - 2015-08-12 00:24:51
|
The branch "master" has been updated in SBCL:
via 8ddae800a5058f80133ca24b4fd223c87ac21907 (commit)
from aaf823cae5205fa9997146498180fa330e4d6a99 (commit)
- Log -----------------------------------------------------------------
commit 8ddae800a5058f80133ca24b4fd223c87ac21907
Author: Douglas Katzman <do...@go...>
Date: Tue Aug 11 19:08:55 2015 -0400
Simplify MAKE-CONDITION, ALLOCATE-CONDITION.
Distinguishing two allegedly different errors in ALLOCATE-CONDITION
was not helpful. If you invoked (ALLOCATE-CONDITION 5), it said
"5 does not designate a condition class" whereas (ALLOCATE-CONDITION T)
said "T is not a condition class". While either message is right,
the former is nicer and more general because it says "designate."
/SHOW0 in WARN was useless because conditions crash cold-init anyway.
Also, ALLOCATE-INSTANCE should not return 2 values.
---
src/code/cold-error.lisp | 48 ++++++++++++++++----------------
src/code/condition.lisp | 59 +++++++++++++++++++---------------------
src/code/cross-condition.lisp | 10 +++++++
src/code/error.lisp | 24 +----------------
src/pcl/slots.lisp | 2 +-
tests/condition.pure.lisp | 2 +-
6 files changed, 65 insertions(+), 80 deletions(-)
diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index 893cc25..7fa8677 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -109,7 +109,7 @@
,@(if possibly-symbolp
`((t (symbol-function f))))))))
(let ((test (car (truly-the cons handler))))
- (when (if (%instancep test) ; a condition classoid
+ (when (if (%instancep test) ; a condition classoid cell
(classoid-cell-typep layout test condition)
(funcall (cast-to-fun test nil) condition))
(funcall (cast-to-fun (cdr handler) t) condition)))))))))
@@ -171,32 +171,32 @@ of condition handling occurring."
(sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
(apply #'%break 'break datum arguments)))
+(defun %warn (datum arguments super default-type)
+ (infinite-error-protect
+ (let ((condition (coerce-to-condition datum arguments default-type 'warn))
+ (superclassoid-name (classoid-name super)))
+ ;: CONDITION is necessarily an INSTANCE,
+ ;; but pedantry requires it be the right subtype of instance.
+ (unless (classoid-typep (%instance-layout condition)
+ super condition)
+ (error 'simple-type-error
+ :datum datum :expected-type superclassoid-name
+ :format-control "~S does not designate a ~A class"
+ :format-arguments (list datum superclassoid-name)))
+ (restart-case (signal condition)
+ (muffle-warning ()
+ :report "Skip warning."
+ (return-from %warn nil)))
+ (format *error-output* "~&~@<~S: ~3i~:_~A~:>~%"
+ superclassoid-name condition)))
+ nil)
+
(defun warn (datum &rest arguments)
#!+sb-doc
"Warn about a situation by signalling a condition formed by DATUM and
ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
exists that causes WARN to immediately return NIL."
- (/show0 "entering WARN")
- (infinite-error-protect
- (/show0 "doing COERCE-TO-CONDITION")
- (let ((condition (coerce-to-condition datum arguments
- 'simple-warning 'warn)))
- (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
- (enforce-type condition warning)
- (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
- (restart-case (signal condition)
- (muffle-warning ()
- :report "Skip warning."
- (return-from warn nil)))
- (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
+ (%warn datum arguments (find-classoid 'warning) 'simple-warning))
- (let ((badness (etypecase condition
- (style-warning 'style-warning)
- (warning 'warning))))
- (/show0 "got BADNESS, calling FORMAT")
- (format *error-output*
- "~&~@<~S: ~3i~:_~A~:>~%"
- badness
- condition)
- (/show0 "back from FORMAT, voila!"))))
- nil)
+(defun style-warn (datum &rest arguments)
+ (%warn datum arguments (find-classoid 'style-warning) 'simple-style-warning))
diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index f1a5e6e..cc7e64c 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -176,56 +176,53 @@
;;;; MAKE-CONDITION
-(defun allocate-condition (type &rest initargs)
- (let* ((classoid (if (symbolp type)
- (find-classoid type nil)
- type))
- (class (typecase classoid
- (condition-classoid classoid)
- (class
- (return-from allocate-condition
- (apply #'allocate-condition (class-name classoid) initargs)))
- (classoid
- (error 'simple-type-error
- :datum classoid
- :expected-type 'condition-class
- :format-control "~S is not a condition class."
- :format-arguments (list type)))
- (t
- (error 'simple-type-error
- :datum type
- :expected-type 'condition-class
- :format-control
- "~S does not designate a condition class."
- :format-arguments (list type)))))
- (condition (%make-condition-object initargs '())))
- (setf (%instance-layout condition) (classoid-layout class))
- (values condition class)))
+(defun allocate-condition (designator &rest initargs)
+ ;; I am going to assume that people are not somehow getting to here
+ ;; with a CLASSOID, which is not strictly legal as a designator,
+ ;; but which is accepted because it is actually the desired thing.
+ ;; It doesn't seem worth sweating over that detail, and in any event
+ ;; we could say that it's a supported extension.
+ (let ((classoid (named-let lookup ((designator designator))
+ (typecase designator
+ (symbol (find-classoid designator nil))
+ (class (lookup (class-name designator)))
+ (t designator)))))
+ (if (condition-classoid-p classoid)
+ (let ((instance (%make-condition-object initargs '())))
+ (setf (%instance-layout instance) (classoid-layout classoid))
+ (values instance classoid))
+ (error 'simple-type-error
+ :datum designator
+ ;; CONDITION-CLASS isn't a type-specifier. Is this legal?
+ :expected-type 'condition-class
+ :format-control "~S does not designate a condition class."
+ :format-arguments (list designator)))))
(defun make-condition (type &rest initargs)
#!+sb-doc
"Make an instance of a condition object using the specified initargs."
- ;; Note: ANSI specifies no exceptional situations in this function.
- ;; signalling simple-type-error would not be wrong.
- (multiple-value-bind (condition class)
+ ;; Note: While ANSI specifies no exceptional situations in this function,
+ ;; ALLOCATE-CONDITION will signal a type error if TYPE does not designate
+ ;; a condition class. This seems fair enough.
+ (multiple-value-bind (condition classoid)
(apply #'allocate-condition type initargs)
;; Set any class slots with initargs present in this call.
- (dolist (cslot (condition-classoid-class-slots class))
+ (dolist (cslot (condition-classoid-class-slots classoid))
(dolist (initarg (condition-slot-initargs cslot))
(let ((val (getf initargs initarg *empty-condition-slot*)))
(unless (eq val *empty-condition-slot*)
(setf (car (condition-slot-cell cslot)) val)))))
;; Default any slots with non-constant defaults now.
- (dolist (hslot (condition-classoid-hairy-slots class))
+ (dolist (hslot (condition-classoid-hairy-slots classoid))
(when (dolist (initarg (condition-slot-initargs hslot) t)
(unless (eq (getf initargs initarg *empty-condition-slot*)
*empty-condition-slot*)
(return nil)))
(setf (getf (condition-assigned-slots condition)
(condition-slot-name hslot))
- (find-slot-default class hslot))))
+ (find-slot-default classoid hslot))))
condition))
diff --git a/src/code/cross-condition.lisp b/src/code/cross-condition.lisp
index a08ee48..fc96e44 100644
--- a/src/code/cross-condition.lisp
+++ b/src/code/cross-condition.lisp
@@ -12,6 +12,16 @@
(in-package "SB!KERNEL")
(define-condition simple-style-warning (simple-condition style-warning) ())
+(defun style-warn (datum &rest arguments)
+ ;; Cross-compiler needs a special-case for DATUM being a string,
+ ;; because it needs to produce a SIMPLE-STYLE-WARNING, not SIMPLE-WARNING.
+ ;; The SBCL-specific %WARN function - which allows specifying the default
+ ;; condition class when handed a string - exists only on the target lisp.
+ (if (stringp datum)
+ (warn 'simple-style-warning
+ :format-control datum :format-arguments arguments)
+ (apply #'warn datum arguments)))
+
(define-condition format-too-few-args-warning (simple-warning) ())
;;; in the cross-compiler, this is a full warning. In the target
;;; compiler, it will only be a style-warning.
diff --git a/src/code/error.lisp b/src/code/error.lisp
index 87be7ec..46cce6e 100644
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -13,21 +13,6 @@
(in-package "SB!KERNEL")
-;;; not sure this is the right place, but where else?
-(defun style-warn (datum &rest arguments)
- (/noshow0 "entering STYLE-WARN")
- (/noshow datum arguments)
- (if (stringp datum)
- (with-sane-io-syntax
- (warn 'simple-style-warning
- :format-control datum
- :format-arguments arguments))
- ;; Maybe FIXME: check that the DATUM is a STYLE-WARNING or a
- ;; specifier for a subtype of STYLE-WARNING? (I had trouble
- ;; getting through cold-init with that check enabled, though.)
- ;; -- RMK, 20080701.
- (apply #'warn datum arguments)))
-
;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and
;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a
;;; single argument that's directly usable by all the other routines.
@@ -42,19 +27,12 @@
when giving ~S to ~S."
:format-arguments (list datum fun-name)))
datum)
- ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
- (apply #'make-condition datum arguments))
((or (stringp datum) (functionp datum))
(make-condition default-type
:format-control datum
:format-arguments arguments))
(t
- (error 'simple-type-error
- :datum datum
- :expected-type '(or symbol string function)
- :format-control "Condition designator ~s is not of type ~s."
- :format-arguments (list datum
- '(or symbol string function))))))
+ (apply #'make-condition datum arguments))))
(define-condition layout-invalid (type-error)
()
diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index ab8a904..12d1ab0 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -510,7 +510,7 @@
(defmethod allocate-instance ((class condition-class) &rest initargs)
(declare (ignore initargs))
- (allocate-condition (class-name class)))
+ (values (allocate-condition (class-name class))))
(macrolet ((def (name class)
`(defmethod ,name ((class ,class) &rest initargs)
diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index de7930e..a3d530e 100644
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -301,7 +301,7 @@
(reader-error (condition) (princ-to-string condition))))))
(with-test (:name (make-condition :non-condition-class))
- (assert (search "not a condition class"
+ (assert (search "does not designate a condition class"
(handler-case
(make-condition 'standard-class)
(type-error (condition)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|