如何在制作实例期间强制检查插槽的类型？

Question

假设我有以下类声明：

(defclass foo-class ()
  ((bar :initarg :bar
        :type list)))

当我创建此类的实例时，make-instance 不会检查传递的参数是否满足插槽类型。因此，我可以通过这种方式创建“无效”对象：

> (make-instance 'foo-class :bar 'some-symb)
#<FOO-CLASS {102BEC5E83}>

但是，我希望看到类似于创建结构实例的行为，其中检查类型：

(defstruct foo-struct
  (bar nil :type list))

> (make-foo-struct :bar 'some-symb)
;; raises contition:
;;
;; The value
;; SOME-SYMB
;; is not of type
;; LIST
;; when setting slot BAR of structure FOO-STRUCT

有什么办法可以做到吗？

Answer 1

结构和 CLOS 实例是否检查槽类型都未定义。

许多实现都会为结构做这件事 - 但不是全部。

很少有实现会为 CLOS 实例做到这一点 - 例如，Clozure CL 实际上就是这样做的。

SBCL 还可以检查 CLOS 插槽类型 - 当安全性很高时：

* (declaim (optimize safety))

NIL
* (progn
(defclass foo-class ()
  ((bar :initarg :bar
        :type list)))
(make-instance 'foo-class :bar 'some-symb))

debugger invoked on a TYPE-ERROR: The value SOME-SYMB is not of type LIST.

Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.

restarts (invokable by number or by possibly-abbreviated name):
  0: [ABORT] Exit debugger, returning to top level.

((SB-PCL::SLOT-TYPECHECK LIST) SOME-SYMB)
0] 

不然怎么办？

这是一种高级主题，可能需要一些 CLOS 元对象协议黑客技术。两种变体：

• 为 SHARED-INITALIZE 定义一个检查 init 参数的方法。

• 为您的类定义一个元类，并在 SET-SLOT-VALUE-USING-CLASS 上定义一个方法。但是你需要确保你的实现确实提供并使用了 SET-SLOT-VALUE-USING-CLASS。这是一个通用函数，它是 MOP 的一部分。有些实现提供它，但有些只在请求时使用它（否则设置插槽可能会降低速度）。

对于后者，这里是自建的SBCL版本，用于检查写入槽的类型：

首先是元类：

; first a metaclass for classes which checks slot writes
(defclass checked-class (standard-class)
  ())

; this is a MOP method, probably use CLOSER-MOP for a portable version
(defmethod sb-mop:validate-superclass
           ((class checked-class)
            (superclass standard-class))
   t)

现在我们检查该元类的所有插槽写入：

; this is a MOP method, probably use CLOSER-MOP for a portable version    
(defmethod (setf sb-mop:slot-value-using-class) :before
              (new-value (class checked-class) object slot)
  (assert (typep new-value (sb-mop:slot-definition-type slot))
      ()
    "new value ~a is not of type ~a in object ~a slot ~a"
    new-value (sb-mop:slot-definition-type slot) object slot))

我们的示例类使用该元类：

(defclass foo-class ()
  ((bar :initarg :bar :type list))
  (:metaclass checked-class))

使用它：

* (make-instance 'foo-class :bar 42)

debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {10005605B3}>:
  new value 42 is not of type LIST
  in object #<FOO-CLASS {1004883143}>
  slot #<STANDARD-EFFECTIVE-SLOT-DEFINITION COMMON-LISP-USER::BAR>

Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.

restarts (invokable by number or by possibly-abbreviated name):
  0: [CONTINUE] Retry assertion.
  1: [ABORT   ] Exit debugger, returning to top level.

Answer 2

sanity-clause 库昨天刚刚合并了一个功能。

Sanity 条款是一个数据验证/合同库。您可以将其用于配置数据、验证 api 响应或数据存储中的文档。在动态类型的语言中，它可以帮助您定义明确定义的怀疑和不确定区域。我们应该爱我们的用户，但我们不应该盲目相信他们的意见。

要使用它，您需要定义模式，它可以是带有符号的属性列表，其中包含 :class:sanity-clause.field:field 的键和实例的符号

所以：

(defclass person ()
     ((favorite-dog :type symbol
                    :field-type :member
                    :members (:wedge :walter)
                    :initarg :favorite-dog
                    :required t)
      (age :type (integer 0)
           :initarg :age
           :required t)
      (potato :type string
              :initarg :potato
              :required t))
     (:metaclass sanity-clause.metaclass:validated-metaclass))

;; bad dog:
(make-instance 'person :favorite-dog :nope)
; Evaluation aborted on Error converting value for field #<MEMBER-FIELD {1004BFA973}>: 
Value "NOPE" couldn't be found in set (WEDGE WALTER)

;; bad age:
(make-instance 'person :age -1 :favorite-dog :walter)
; Evaluation aborted on Error validating value -1 in field #<INTEGER-FIELD {1004BFF103}>:
* Value -1 didn't satisfy condition "must be larger than 0"

;; missing potato:
(make-instance 'person :age 7 :favorite-dog :walter)
; Evaluation aborted on A value for field POTATO is required but none was provided..

;; all OK:
(make-instance 'person :age 1 :favorite-dog :walter :potato "patate")
#<PERSON {10060371E3}>