-
chevron_right
CHECK-TYPE* - CHECK-TYPE, except the type is evaluated
Michał "phoe" Herda · Sunday, 5 July, 2020 - 11:09 · 1 minute
Someone seemed to need a CHECK-TYPE
variant whose type is evaluated at runtime instead of being fixed at compile-time.
I quickly gutted out some code from PCS and produced the following code.
;;;; Based on Portable Condition System (License: CC0)
(defun store-value-read-evaluated-form ()
(format *query-io* "~&;; Type a form to be evaluated:~%")
(list (eval (read *query-io*))))
(defmacro with-store-value-restart ((temp-var place tag) &body forms)
(let ((report-var (gensym "STORE-VALUE-REPORT"))
(new-value-var (gensym "NEW-VALUE"))
(form-or-forms (if (= 1 (length forms)) (first forms) `(progn ,@forms))))
`(flet ((,report-var (stream)
(format stream "Supply a new value of ~S." ',place)))
(restart-case ,form-or-forms
(store-value (,new-value-var)
:report ,report-var
:interactive store-value-read-evaluated-form
(setf ,temp-var ,new-value-var
,place ,new-value-var)
(go ,tag))))))
(defun check-type-error (place value type type-string)
(error
'simple-type-error
:datum value
:expected-type type
:format-control (if type-string
"The value of ~S is ~S, which is not ~A."
"The value of ~S is ~S, which is not of type ~S.")
:format-arguments (list place value (or type-string type))))
(defmacro check-type* (place type &optional type-string)
"Like CHECK-TYPE, except TYPE is evaluated on each assertion."
(let ((variable (gensym "CHECK-TYPE-VARIABLE"))
(tag (gensym "CHECK-TYPE-TAG"))
(type-gensym (gensym "CHECK-TYPE-TYPE")))
`(let ((,variable ,place))
(tagbody ,tag
(let ((,type-gensym ,type))
(unless (typep ,variable ,type-gensym)
(with-store-value-restart (,variable ,place ,tag)
(check-type-error ',place ,variable ,type-gensym
,type-string))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
CL-USER> (let ((x 2)) (check-type* x 'integer))
NIL
CL-USER> (handler-case (let ((x 2)) (check-type* x 'string))
(error (e) (princ-to-string e)))
"The value of X is 2, which is not of type STRING."