classes.*: new words contained-classes and all-contained-classes

it is to generalize the logic used for checking if union classes
self-references

diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 05e88b9663741fc6400eb639ccd8f6da2a400dd1..0ee96e1ead6c4431c352b69f6653127f53ee41dc 100644 (file)
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -72,17 +72,32 @@ ABOUT: "classes"
 HELP: class
 { $class-description "The class of all class words." } ;
 
+HELP: class-members
+{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
+{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
+
 HELP: class-of
 { $values { "object" object } { "class" class } }
 { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
 { $examples { $example "USING: classes prettyprint ;" "1.0 class-of ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class-of ." "point" } } ;
 
+HELP: class-usage
+{ $values { "class" class } { "seq" sequence } }
+{ $description "Lists all classes that uses or depends on this class." } ;
+
 HELP: classes
 { $values { "seq" "a sequence of class words" } }
 { $description "Finds all class words in the dictionary." } ;
 
-HELP: update-map
-{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
+HELP: contained-classes
+{ $values { "obj" class } { "members" sequence } }
+{ $description "Lists all classes contained in the class." }
+{ $see-also all-contained-classes } ;
+
+HELP: define-predicate
+{ $values { "class" class } { "quot" quotation } }
+{ $description "Defines a predicate word for a class." }
+$low-level-note ;
 
 HELP: predicate-def
 { $values { "obj" "a type object" } { "quot" quotation } }
@@ -99,11 +114,6 @@ HELP: predicate-word
 { $values { "word" word } { "predicate" "a predicate word" } }
 { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
 
-HELP: define-predicate
-{ $values { "class" class } { "quot" quotation } }
-{ $description "Defines a predicate word for a class." }
-$low-level-note ;
-
 HELP: superclass-of
 { $values { "class" class } { "super" class } }
 { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
@@ -140,11 +150,11 @@ HELP: subclass-of?
     }
 } ;
 
-{ superclass-of superclasses-of subclass-of? } related-words
+HELP: update-map
+{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." }
+{ $see-also class-usage } ;
 
-HELP: class-members
-{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
-{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
+{ superclass-of superclasses-of subclass-of? } related-words
 
 HELP: class-participants
 { $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }

diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index dfc74fe69ca67db72995b4048b53401709ab5b55..59b11232c4fe93f4ec49f7872ef6366163a3aed9 100644 (file)
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -112,3 +112,31 @@ GENERIC: generic-predicate? ( a -- b )
 { } [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test
 
 { f } [ \ generic-predicate? generic? ] unit-test
+
+! all-contained-classes
+{
+    { maybe{ integer } integer fixnum bignum }
+} [
+    { maybe{ integer } } all-contained-classes
+] unit-test
+
+! contained-classes
+{
+    { fixnum bignum }
+    { integer }
+} [
+    integer contained-classes
+    maybe{ integer } contained-classes
+] unit-test
+
+! make-class-props
+{
+    H{
+        { "superclass" f }
+        { "members" { fixnum } }
+        { "metaclass" f }
+        { "participants" { } }
+    }
+} [
+    f { fixnum } { } f  make-class-props
+] unit-test

diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index fefdf97f6de626733c67f6844b349fdbad499fa5..c41f3152fa7bab566c43e72250899cb6b62ccbeb 100644 (file)
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -121,6 +121,15 @@ M: predicate reset-word
     ! Output f for non-classes to work with algebra code
     dup class? [ "participants" word-prop ] [ drop f ] if ;
 
+GENERIC: contained-classes ( obj -- members )
+
+M: object contained-classes
+    "members" word-prop ;
+
+: all-contained-classes ( members -- members' )
+    dup dup [ contained-classes ] map concat sift append
+    2dup set= [ drop members ] [ nip all-contained-classes ] if ;
+
 GENERIC: implementors ( class/classes -- seq )
 
 ! update-map

diff --git a/core/classes/maybe/maybe.factor b/core/classes/maybe/maybe.factor
index a1ed5d18045cd1e808b799656052a8648185a79f..d7a6427548c7c7d8964388d426f9e682854c09a0 100644 (file)
--- a/core/classes/maybe/maybe.factor
+++ b/core/classes/maybe/maybe.factor
@@ -34,5 +34,5 @@ M: maybe class-name
 M: maybe predicate-def
     class>> predicate-def [ [ t ] if* ] curry ;
 
-M: maybe classes-contained-by
+M: maybe contained-classes
     class>> 1array ;

diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 0e4cf5742a44ea3773c53632c9ac42e2aa2138c0..e821b151a3b8ae7ca95fe4ecc1ee1612316d6ea3 100644 (file)
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -55,20 +55,8 @@ M: union-class update-class define-union-predicate ;
 
 ERROR: cannot-reference-self class members ;
 
-GENERIC: classes-contained-by ( obj -- members )
-
-M: union-class classes-contained-by ( union -- members )
-    "members" word-prop [ f ] when-empty ;
-
-M: object classes-contained-by
-    "members" word-prop [ f ] when-empty ;
-
 : check-self-reference ( class members -- class members )
-    2dup [
-        dup dup [ classes-contained-by ] map concat sift append
-        2dup set= [ 2drop f ] [ nip ] if
-    ] follow concat
-    member-eq? [ cannot-reference-self ] when ;
+    2dup all-contained-classes member-eq? [ cannot-reference-self ] when ;
 
 PRIVATE>