Permalink
Browse files

Try to avoid calls to `change-class`.

By creating our own slot-definition class, we can catch accessors before the methods are created and create a compatible generic function off the bat (provided the function hasn't been created elsewhere). We'll still have some `change-class` calls, but this should reduce it. (Thanks to Pascal Costanza for the suggestion.)
  • Loading branch information...
1 parent cae3178 commit 95158fcdfd1ed7530e09560cb5370c3f6c2ec42c @sellout committed Apr 8, 2012
Showing with 35 additions and 8 deletions.
  1. +35 −8 src/metaclass.lisp
View
@@ -1,12 +1,43 @@
(in-package #:quid-pro-quo)
+(defun ensure-contracted-function (function-name lambda-list)
+ "This both ensures that the method combination is correct as well as that the
+ correct version of STANDARD-GENERIC-FUNCTION is used (for some
+ implementations, Closer-MOP's STANDARD-GENERIC-FUNCTION is different from
+ CL's)."
+ (ensure-generic-function function-name
+ ;; FIXME: CCL & SBCL blow up if we try to
+ ;; CHANGE-CLASS here.
+ #-(or ccl sbcl) :generic-function-class
+ #-(or ccl sbcl) 'standard-generic-function
+ :lambda-list lambda-list
+ :method-combination *contract-method-combination*))
+
+(defclass contracted-direct-slot-definition (standard-direct-slot-definition)
+ ()
+ (:documentation
+ "Use this for slots on CONTRACTED-CLASS so we can ensure the accessors are of
+ the proper type ahead of time, to cut down on unnecessary CHANGE-CLASSes
+ down the line."))
+
+(defmethod initialize-instance :after
+ ((instance contracted-direct-slot-definition) &key &allow-other-keys)
+ (mapc (rcurry #'ensure-contracted-function '(object))
+ (slot-definition-readers instance))
+ (mapc (rcurry #'ensure-contracted-function '(new-value object))
+ (slot-definition-writers instance)))
+
(defclass contracted-class (standard-class)
((invariants :initform () :initarg :invariants
:reader direct-class-invariants)
(invariant-descriptions :initform ()))
(:documentation
"This is the metaclass for any classes you want to add invariants to."))
+(defmethod direct-slot-definition-class
+ ((class contracted-class) &key &allow-other-keys)
+ (find-class 'contracted-direct-slot-definition))
+
(defclass funcallable-contracted-class
(contracted-class funcallable-standard-class)
()
@@ -113,19 +144,15 @@
finally (return t)))
(defun passes-invariants-p (object)
+ "This checks that an instance passes all the class invariants."
(and (passes-slot-type-invariants-p object)
(passes-class-invariants-p object)))
(defun add-invariant
(function-name description lambda-list specializers lambda-body)
- (let* ((generic-function (ensure-generic-function
- function-name
- ;; FIXME: CCL & SBCL blow up if we try to
- ;; CHANGE-CLASS here.
- #-(or ccl sbcl) :generic-function-class
- #-(or ccl sbcl) 'standard-generic-function
- :lambda-list lambda-list
- :method-combination *contract-method-combination*))
+ "Adds an invariant to the provided generic function."
+ (let* ((generic-function (ensure-contracted-function function-name
+ lambda-list))
(method-prototype (class-prototype (find-class 'standard-method)))
(method-function (compile nil
(make-method-lambda generic-function

0 comments on commit 95158fc

Please sign in to comment.