Commit fbfe9405 authored by Pascal Costanza's avatar Pascal Costanza
Browse files

Class initialization patches.

The correction of lists of direct superclasses was done at the wrong place (in :around methods on initialize-instance and reinitialize-instance). The MOP specification doesn't allow to define primary methods for initialize-instance and reinitialize-instance, but these are the only places where those lists can be corrected in a reasonable way. This affects LispWorks and MCL.

Further changes:
- The typep implementation for MCL was incorrect.
- reinitialize-instance for standard-class could be simplified.
- reinitialize-instance for standard-generic-function could be simplified.

darcs-hash:c8e542ff6d11161f8c50c8595710590711c6732b
parent ead2abc1
......@@ -115,21 +115,34 @@
;; - Removal of direct subclasses.
(cl:defmethod initialize-instance :around
((class standard-class)
&rest initargs
&key (direct-superclasses ())
&allow-other-keys)
((class standard-class) &rest initargs)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:optimize-slot-access nil
initargs))
(cl:defmethod initialize-instance
((class standard-class)
&rest initargs
&key (direct-superclasses ())
&allow-other-keys)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:direct-superclasses (modify-superclasses direct-superclasses)
initargs))
(cl:defmethod reinitialize-instance :around
((class standard-class)
&rest initargs
&key (direct-superclasses () direct-superclasses-p)
&allow-other-keys)
((class standard-class) &rest initargs)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:optimize-slot-access nil
initargs))
(cl:defmethod reinitialize-instance
((class standard-class)
&rest initargs
&key (direct-superclasses () direct-superclasses-p)
&allow-other-keys)
(declare (dynamic-extent initargs))
(when direct-superclasses-p
(setq direct-superclasses (modify-superclasses direct-superclasses))
......@@ -138,29 +151,39 @@
do (remove-direct-subclass superclass class)))
(if direct-superclasses-p
(apply #'call-next-method class
:optimize-slot-access nil
:direct-superclasses direct-superclasses
initargs)
(apply #'call-next-method class
:optimize-slot-access nil
initargs)))
(call-next-method)))
(cl:defmethod initialize-instance :around
((class funcallable-standard-class)
&rest initargs
&key (direct-superclasses ())
&allow-other-keys)
((class funcallable-standard-class) &rest initargs)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:optimize-slot-access nil
initargs))
(cl:defmethod initialize-instance
((class funcallable-standard-class)
&rest initargs
&key (direct-superclasses ())
&allow-other-keys)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:direct-superclasses (modify-superclasses direct-superclasses nil)
initargs))
(cl:defmethod reinitialize-instance :around
((class funcallable-standard-class)
&rest initargs
&key (direct-superclasses () direct-superclasses-p)
&allow-other-keys)
((class funcallable-standard-class) &rest initargs)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:optimize-slot-access nil
initargs))
(cl:defmethod reinitialize-instance
((class funcallable-standard-class)
&rest initargs
&key (direct-superclasses () direct-superclasses-p)
&allow-other-keys)
(declare (dynamic-extent initargs))
(when direct-superclasses-p
(setq direct-superclasses (modify-superclasses direct-superclasses nil))
......@@ -169,12 +192,9 @@
do (remove-direct-subclass superclass class)))
(if direct-superclasses-p
(apply #'call-next-method class
:optimize-slot-access nil
:direct-superclasses direct-superclasses
initargs)
(apply #'call-next-method class
:optimize-slot-access nil
initargs)))
(call-next-method)))
;; The following is necessary for forward-referenced-classes.
;; Since we replace the original funcallable-standard-object with
......
......@@ -62,23 +62,23 @@
direct-superclasses
(remove standard-object direct-superclasses)))))
(cl:defmethod initialize-instance :around
((class standard-class)
&rest initargs
&key (name (gensym))
(direct-superclasses ())
&allow-other-keys)
(cl:defmethod initialize-instance
((class standard-class)
&rest initargs
&key (name (gensym))
(direct-superclasses ())
&allow-other-keys)
(declare (dynamic-extent initargs))
(apply #'call-next-method class
:name name
:direct-superclasses (modify-superclasses direct-superclasses)
initargs))
(cl:defmethod reinitialize-instance :around
((class standard-class)
&rest initargs
&key (direct-superclasses () direct-superclasses-p)
&allow-other-keys)
(cl:defmethod reinitialize-instance
((class standard-class)
&rest initargs
&key (direct-superclasses () direct-superclasses-p)
&allow-other-keys)
(declare (dynamic-extent initargs))
(if direct-superclasses-p
(apply #'call-next-method class
......@@ -91,7 +91,7 @@
(cl:typep object type))
(:method (object (type class))
(member (class-of object)
(class-precedence-list class))))
(class-precedence-list type))))
(defgeneric subtypep (type1 type2)
(:method (type1 type2)
......
......@@ -83,11 +83,9 @@
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(cl:defmethod reinitialize-instance :around
((class standard-class) &rest initargs)
(declare (dynamic-extent initargs))
(prog1 (apply #'call-next-method class initargs)
(modify-accessors class)))
(cl:defmethod reinitialize-instance :after
((class standard-class) &key)
(modify-accessors class))
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
......@@ -105,9 +103,7 @@
((gf standard-generic-function) &rest initargs)
(declare (dynamic-extent initargs))
(set-funcallable-instance-function
gf
#+cmu (clos-mop:compute-discriminating-function gf)
#+sbcl (sb-mop:compute-discriminating-function gf))
gf (compute-discriminating-function gf))
(map-dependents
gf (lambda (dep) (apply #'update-dependent gf dep initargs))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment