• person rss_feed

    Michał "phoe" Herda’s feed

    Blog

    • 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."
    
    • wifi_tethering open_in_new

      This post is public

      nl.movim.eu