Plaster
New
List
Login
common-lisp
default
phoe
2020.08.22 00:08:43
(defclass typechecked-class (standard-class) ()) (defclass typechecked-slot (m:standard-slot-definition) ()) (defclass typechecked-direct-slot-definition (m:standard-direct-slot-definition typechecked-slot) ()) (defclass typechecked-effective-slot-definition (m:standard-effective-slot-definition typechecked-slot) ((typecheck-function :reader typecheck-function))) (defmethod m:validate-superclass ((c typechecked-class) (s standard-class)) t) (defmethod m:validate-superclass ((c standard-class) (s typechecked-class)) t) (defmethod m:direct-slot-definition-class ((class typechecked-class) &key (type nil typep) &allow-other-keys) (declare (ignore type)) (if typep (find-class 'typechecked-direct-slot-definition) (call-next-method))) (defmethod m:effective-slot-definition-class ((class typechecked-class) &key &allow-other-keys) (find-class 'typechecked-effective-slot-definition)) (defmethod m:compute-effective-slot-definition ((class typechecked-class) name dsds) (let* ((esd (call-next-method)) (type (m:slot-definition-type esd)) (typecheck-function (compile nil `(lambda (,name) (check-type ,name ,type) ,name)))) (setf (slot-value esd 'typecheck-function) typecheck-function) esd)) (defmethod (setf m:slot-value-using-class) :around (new-value (class typechecked-class) object (slot typechecked-effective-slot-definition)) (setf new-value (funcall (typecheck-function slot) new-value)) (call-next-method new-value class object slot)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; VALUE-SEMANTICS-CLASS> (defclass foo () ((bar :type number :initarg :bar :accessor bar)) (:metaclass typechecked-class)) #<TYPECHECKED-CLASS VALUE-SEMANTICS-CLASS::FOO> VALUE-SEMANTICS-CLASS> (defvar *foo* (make-instance 'foo)) *FOO* VALUE-SEMANTICS-CLASS> (setf (bar *foo*) 42) 42 VALUE-SEMANTICS-CLASS> (bar *foo*) 42 VALUE-SEMANTICS-CLASS> (setf (bar *foo*) :forty-two) ;;; Error: The value of BAR is :FORTY-TWO, which is not of type NUMBER. ;;; [Condition of type SIMPLE-TYPE-ERROR] ;;; ;;; Invoke restart: [STORE-VALUE] Supply a new value for BAR. ;;; Enter a form to be evaluated: 2424 2424 VALUE-SEMANTICS-CLASS> (bar *foo*) 2424
Raw
Annotate
Repaste