[closer-devel] Redefining classes
Michael Weber
michaelw+closer at foldr.org
Thu Dec 1 19:27:43 UTC 2005
* Pascal Costanza <pc at p-cos.net> [2005-12-01T17:21+0100]:
> On 1 Dec 2005, at 11:22, Michael Weber wrote:
[...]
Thanks for the quick answer, Pascal. I am trying to wrap my head
around this now. I might sound a little confusing, as I am not yet
using the right terminology in all cases. I'll try to fix that. :)
> >Is there a way to invalidate and reinitialize all subclasses? I would
> >assume that that's a common issue.
>
> I don't think there's a need to do that. Or do you have evidence that
> something's going wrong here? If so, could you be more specific -
> including which Common Lisp implementation you use?
CL-USER> (list (lisp-implementation-type) (lisp-implementation-version))
("SBCL" "0.8.16")
It's old, I know. Various reason hold me off to upgrade it. If there
have been relevant bug fixes affecting the code below, I'll apologize
for wasting everybody's time. I'd have to suspend this experiment
then until I can upgrade.
> Maybe it's a good idea to tell us your overall goal - what is it that
> you are actually trying to achieve?
Automatically generating equality methods for objects (EQL-OBJECTS,
with EQUALS being the user interface). Code attached. It's quite
rough around the edges, as I am just writing this. Notice that I am
generating code for all (CLASS-SLOTS class), which returns a list of
effective slot definition objects.
My test code looks like this:
(define-eql-class bar ()
((slot-1 :reader slot-1
:initarg :slot-1
:equality equals)
(slot-2 :reader slot-2
:initarg :slot-2)))
(define-eql-class bar-1 (bar)
((slot-3 :initarg :slot-3
:equality equal)))
I tried to attach my method generation code to FINALIZE-INHERITANCE
first:
;;;; (define-eql-class bar-1 (bar) ((slot-3 :initarg :slot-3 ...
0: (FINALIZE-INHERITANCE #<EQL-CLASS BAR-1>)
0: FINALIZE-INHERITANCE returned NIL
;;;; (define-eql-class bar-1 (bar) ((slot-3 :initarg :slot-3 ...
CL-USER> (make-instance 'bar-1)
#<BAR-1 {916B1A9}>
CL-USER>
With my SBCL, FINALIZE-INHERITANCE seems to be called the first time a
class is defined, but _not_ if it is redefined. I think that's
contrary to what AMOP says should happen. (Issue #1)
To be able to proceed, I worked around it by instead using an :after
method on SHARED-INITIALIZE for my metaclass, which is called
everytime I redefine a class (I traced it):
;;;; (define-eql-class bar () ((slot-1 :reader slot-1 ...
(SHARED-INITIALIZE #<EQL-CLASS BAR>)
;;;; (define-eql-class bar () ((slot-1 :reader slot-1 ...
(SHARED-INITIALIZE #<EQL-CLASS BAR>)
The real problem comes up if I redefine class BAR (removing slots),
without redefining its subclasses, namely BAR-1:
CL-USER> (define-eql-class bar ()
((slot-1 :reader slot-1
:initarg :slot-1
:equality equals)))
#<EQL-CLASS BAR>
Let's check that EQUAL-OBJECTS method for BAR was updated wrt. to the
now removed slot:
CL-USER> (equals #1=(make-instance 'bar) #1#)
(FROM-CLASS
(AND
(IF (SLOT-BOUNDP X 'SLOT-1)
(AND (SLOT-BOUNDP Y 'SLOT-1)
(FUNCALL #'EQUALS (SLOT-VALUE X 'SLOT-1) (SLOT-VALUE Y 'SLOT-1)))
(NOT (SLOT-BOUNDP Y 'SLOT-1)))))
T
CL-USER>
Indeed, it is updated (no mention of SLOT-2). Now let's check with
BAR-1:
CL-USER> (equals #1=(make-instance 'bar-1) #1#)
(FROM-CLASS
(AND
(IF (SLOT-BOUNDP X 'SLOT-3)
(AND (SLOT-BOUNDP Y 'SLOT-3)
(FUNCALL #'EQUAL (SLOT-VALUE X 'SLOT-3) (SLOT-VALUE Y 'SLOT-3)))
(NOT (SLOT-BOUNDP Y 'SLOT-3)))
(IF (SLOT-BOUNDP X 'SLOT-1)
(AND (SLOT-BOUNDP Y 'SLOT-1)
(FUNCALL #'EQUALS (SLOT-VALUE X 'SLOT-1) (SLOT-VALUE Y 'SLOT-1)))
(NOT (SLOT-BOUNDP Y 'SLOT-1)))
(IF (SLOT-BOUNDP X 'SLOT-2)
(AND (SLOT-BOUNDP Y 'SLOT-2)
(FUNCALL #'EQL (SLOT-VALUE X 'SLOT-2) (SLOT-VALUE Y 'SLOT-2)))
(NOT (SLOT-BOUNDP Y 'SLOT-2)))))
I get the following condition:
When attempting to test to see whether slot is bound (SLOT-BOUNDP), the slot
SLOT-2 is missing from the object #<BAR-1 {9E4D739}>.
[Condition of type SIMPLE-ERROR]
That's not very surprising, if the EQUAL-OBJECTS method for BAR-1 was
not updated, and thus still contains code to access SLOT-2 (of BAR).
However, it is surprising to me that there seems to be no protocol
available to reinitialize subclasses if a class changes (Issue #2), so
that EQL-OBJECTS for BAR-1 would be regenerated with up-to-date
information about class slots of its superclasses.
Then again, maybe I really should be using CLASS-DIRECT-SLOTS and
generate methods somewhat like this:
(let* (...
;;; use only the effective slots objects corresponding
;;; to direct slots
(direct-effective-slots (intersection (class-slots class)
(class-direct-slots class)
:key #'slot-definition-name))
(comparison-code
`(AND ,@(loop for slot in direct-effective-slots
for s-d-name = (slot-definition-name slot)
for equality = (eql-effective-slot-definition-equality slot)
collect `(IF (SLOT-BOUNDP X ',s-d-name)
(AND (SLOT-BOUNDP Y ',s-d-name)
(FUNCALL (FUNCTION ,equality)
(SLOT-VALUE X ',s-d-name)
(SLOT-VALUE Y ',s-d-name)))
(NOT (SLOT-BOUNDP Y ',s-d-name))))
;;; defer work to previously generated instances
(CALL-NEXT-METHOD))))
...)
Calls look like this then:
CL-USER> (equals #1=(make-instance 'bar-1) #1#)
(FROM-CLASS
(AND
(IF (SLOT-BOUNDP X 'SLOT-3)
(AND (SLOT-BOUNDP Y 'SLOT-3)
(FUNCALL #'EQUAL (SLOT-VALUE X 'SLOT-3) (SLOT-VALUE Y 'SLOT-3)))
(NOT (SLOT-BOUNDP Y 'SLOT-3)))
(CALL-NEXT-METHOD)))
(FROM-CLASS
(AND
(IF (SLOT-BOUNDP X 'SLOT-1)
(AND (SLOT-BOUNDP Y 'SLOT-1)
(FUNCALL #'EQUALS (SLOT-VALUE X 'SLOT-1) (SLOT-VALUE Y 'SLOT-1)))
(NOT (SLOT-BOUNDP Y 'SLOT-1)))
(IF (SLOT-BOUNDP X 'SLOT-2)
(AND (SLOT-BOUNDP Y 'SLOT-2)
(FUNCALL #'EQL (SLOT-VALUE X 'SLOT-2) (SLOT-VALUE Y 'SLOT-2)))
(NOT (SLOT-BOUNDP Y 'SLOT-2)))
(CALL-NEXT-METHOD)))
(BASE-CASE T)
T
CL-USER>
That works, but I am not too happy about it for various reasons.
Also, I did not think through what happens in the case of more funky
inheritance relationships.
So, that still leaves me with Issues #1 and #2, which both might as
well be figments of my imagination, and I am doing things simply the
wrong way. :)
Cheers,
Michael
-------------- next part --------------
(use-package #+sbcl :sb-pcl) ;XXX
(defclass eql-class (standard-class)
())
(defclass eql-direct-slot-definition (standard-direct-slot-definition)
((equality :initarg :equality
:reader eql-direct-slot-definition-equality)))
(defclass eql-effective-slot-definition (standard-effective-slot-definition)
((equality :initarg :indices :initform 'eql
:accessor eql-effective-slot-definition-equality)))
(defgeneric EQL-OBJECTS (type x y)
(:documentation "Equality on objects X and Y modulo type TYPE.")
(:method (type x y)
(print `(AND (TYPEP X TYPE) (TYPEP Y TYPE) ;XXX
(EQL X Y)))
(and (typep x type) (typep y type)
(eql x y))))
(defun equals (x y &optional (type t))
(EQL-OBJECTS type x y))
(defun %simple-add-method (gf &key lambda-list specializers method-body qualifiers)
(let* ((method-class (generic-function-method-class gf)))
(multiple-value-bind (method-lambda initargs)
(make-method-lambda gf (class-prototype method-class)
method-body
nil)
(add-method gf
(apply #'make-instance method-class
:function (compile nil method-lambda)
:specializers specializers
:qualifiers qualifiers
:lambda-list lambda-list
initargs)))))
;; (defmethod finalize-inheritance :after ((class eql-class))
(defmethod shared-initialize :after ((class eql-class) slot-names &rest initargs
&key &allow-other-keys)
(declare (ignore slot-names initargs))
(print (list 'shared-initialize class))
(let* ((gf (ensure-generic-function 'EQL-OBJECTS))
(slots (class-slots class))
(lambda-list '(TYPE X Y))
(comparison-code
`(AND ,@(loop for slot in (reverse slots)
for s-d-name = (slot-definition-name slot)
for equality = (eql-effective-slot-definition-equality slot)
collect `(IF (SLOT-BOUNDP X ',s-d-name)
(AND (SLOT-BOUNDP Y ',s-d-name)
(FUNCALL (FUNCTION ,equality)
(SLOT-VALUE X ',s-d-name)
(SLOT-VALUE Y ',s-d-name)))
(NOT (SLOT-BOUNDP Y ',s-d-name)))))))
(%simple-add-method gf
:lambda-list lambda-list
:specializers (list (intern-eql-specializer t)
class class)
:method-body `(LAMBDA ,lambda-list
(print ',(list 'from-class comparison-code)) ;XXX
(OR (EQ X Y)
(AND (EQ (CLASS-OF X) (CLASS-OF Y))
,comparison-code))))
(%simple-add-method gf
:lambda-list lambda-list
:specializers (list (intern-eql-specializer (class-name class))
(find-class t) (find-class t))
:method-body `(LAMBDA ,lambda-list
(print ',(list 'from-type comparison-code)) ;XXX
(OR (EQ X Y)
(AND (TYPEP X TYPE) (TYPEP Y TYPE)
,comparison-code))))))
(defmethod validate-superclass ((class eql-class) (superclass standard-class))
t)
;;XXX what if a STANDARD-CLASS class inherits from an EQL-CLASS class?
(defmethod direct-slot-definition-class ((class eql-class)
&key (equality nil equality-supplied-p)
&allow-other-keys)
(declare (ignore equality))
(if equality-supplied-p
(find-class 'eql-direct-slot-definition)
(call-next-method)))
(defmethod effective-slot-definition-class ((class eql-class) &rest initargs)
(declare (ignore initargs))
(find-class 'eql-effective-slot-definition))
(defmethod compute-effective-slot-definition ((class eql-class) name direct-slots)
(declare (ignore name))
(let* ((normal-slot (call-next-method))
(equality-slots (remove-if (lambda (slot)
(not (typep slot 'eql-direct-slot-definition)))
direct-slots))
(direct-equality-slot (first equality-slots))) ;XXX slot inheritance?
(prog1 normal-slot
(unless (null direct-equality-slot)
(setf (eql-effective-slot-definition-equality normal-slot)
(eql-direct-slot-definition-equality direct-equality-slot))))))
;XXX COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS?
(defmacro define-eql-class (name superclasses slots &rest options)
(when (assoc :metaclass options)
(error "metaclass option not allowed on eql-class"))
`(defclass ,name ,superclasses
,slots
, at options
(:metaclass eql-class)))
More information about the closer-devel
mailing list