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

Added utility function subclassp.

Some CLOS implementations have problems with determining subtype relationships between classes in certain corner cases. For example, clisp doesn't like to determine such relationships for forward referenced classes, and some instances of PCL have problems with anonymous classes under certain circumstances (primarily when doing CLOS MOP programming).

Apparently, subtypep is typically implemented based on the class precedence list, which can only be determined until after a class has been finalized, and this seems to be one of the reasons for these problems. However, the CLOS MOP places restrictions on methods for compute-class-precedence-list such that the subtype relationship actually does _not_ depend on the precedence list, but can be based on a membership test in the unordered set of all direct and indirect superclasses.

I have provided subclassp in Closer to MOP as a utility function that does just that: It walks the superclass hierarchy to determine whether one class is a subclass of another. This implementation is not that efficient, so it should only be used when subtypep fails. (It could probably be made more efficient, but since this is only provided as a replacement for subtypep in hopefully rare corner cases, I haven't put the energy into this to do this yet.)

darcs-hash:1577003438ad08385a1e4f7cf24254fce79ea359
parent ba8feb0f
......@@ -122,6 +122,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
......
......@@ -14,6 +14,28 @@
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
;; We need a new standard-class for various things.
(cl:defclass standard-class (cl:standard-class)
......
......@@ -113,6 +113,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
......
......@@ -17,6 +17,28 @@
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
(defun ensure-method (gf lambda-expression
&key (qualifiers ())
(lambda-list (cadr lambda-expression))
......
......@@ -120,6 +120,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#-ecl #:add-dependent
......
......@@ -27,6 +27,28 @@
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
(defun extract-lambda-list (lambda-list)
(loop for (arg . rest) on lambda-list
until (member arg lambda-list-keywords)
......
......@@ -125,6 +125,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#-lispworks4.3 #:accessor-method-slot-definition
#:add-dependent
......
......@@ -14,6 +14,28 @@
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
;; We need a new standard-generic-function for various things.
(cl:defclass standard-generic-function (cl:standard-generic-function)
......
......@@ -125,6 +125,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
......
......@@ -19,6 +19,28 @@
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
#-(or clozure-common-lisp openmcl)
(progn
;; We need a new standard-class for various things.
......
......@@ -123,6 +123,7 @@
#:ensure-method
#:fix-slot-initargs
#:required-args
#:subclassp
#:accessor-method-slot-definition
#:add-dependent
......
......@@ -19,6 +19,28 @@
(when errorp (error "~S is not a class." class)))
class)
(defun subclassp (class superclass)
(flet ((get-class (class) (etypecase class
(class class)
(symbol (find-class class)))))
(loop with class = (get-class class)
with superclass = (get-class superclass)
for superclasses = (list class)
then (set-difference
(union (class-direct-superclasses current-class) superclasses)
seen)
for current-class = (first superclasses)
while current-class
if (eq current-class superclass) return t
else collect current-class into seen
finally (return nil))))
;; The following is commented out. SBCL now supports compatible standard-class and
;; funcallable-standard-class metaclasses, but this requires that we don't mess with
;; the class hierarchy anymore. So we will try the trick we have already used
......
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