[Openmcl-cvs-notifications] r8988 - /trunk/source/level-1/l1-error-system.lisp

[gb at clozure.com]

Author: gb
Date: Wed Apr  2 04:13:55 2008
New Revision: 8988

Log:
Define %CHECK-TYPE, which just sets up the STORE-VALUE restart for
CHECK-TYPE.  (CHECK-TYPE will expand into a call to this if an
initial TYPEP fails; that can cause lots of warnings during
REBUILD-CCL et al.  Ignore them.)



Modified:
    trunk/source/level-1/l1-error-system.lisp

Modified: trunk/source/level-1/l1-error-system.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-error-system.lisp (original)
+++ trunk/source/level-1/l1-error-system.lisp Wed Apr  2 04:13:55 2008
@@ -986,6 +986,21 @@
                    (apply (setf (symbol-function function-name) function) =
args)))))
 =

 =

+(defun %check-type (value typespec placename typename)
+  (let ((condition (make-condition 'type-error =

+                                   :datum value
+                                   :expected-type typespec)))
+    (if typename
+      (setf (slot-value condition 'format-control)
+            (format nil "value ~~S is not ~A (~~S)." typename)))
+    (restart-case (%error condition nil (%get-frame-ptr))
+                  (store-value (newval)
+                               :report (lambda (s)
+                                         (format s "Assign a new value of =
type ~a to ~s" typespec placename))
+                               :interactive (lambda ()
+                                              (format *query-io* "~&New va=
lue for ~S :" placename)
+                                              (list (eval (read))))
+                               newval))))
 =

 =

 ; This has to be defined fairly early (assuming, of course, that it "has" =
to be defined at all ...