Working on classes

core/classes/classes-docs.factor

@@ -1,7 +1,7 @@
 USING: help.markup help.syntax kernel kernel.private
 namespaces sequences words arrays layouts help effects math
 layouts classes.private classes.union classes.mixin
-classes.predicate ;
+classes.predicate quotations ;
 IN: classes
 
 ARTICLE: "builtin-classes" "Built-in classes"
@@ -114,24 +114,9 @@ HELP: predicate-word
 { $values { "word" "a 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 } { "predicate" "a predicate word" } { "quot" "a quotation" } }
-{ $description
-    "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
-    { $list
-        { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
-        { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
-        { "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
-    }
-    "These properties are used by method dispatch and the help system."
-}
-$low-level-note ;
-
 HELP: define-predicate
-{ $values { "class" class } { "quot" "a quotation" } }
-{ $description
-    "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
-}
+{ $values { "class" class } { "quot" quotation } }
+{ $description "Defines a predicate word for a class." }
 $low-level-note ;
 
 HELP: superclass

core/classes/classes-tests.factor

@@ -178,39 +178,39 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
 
 [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
 
-DEFER: mixin-forget-test-g
-
-[ "mixin-forget-test" forget-source ] with-compilation-unit
-
-[ ] [
-    {
-        "USING: sequences ;"
-        "IN: classes.tests"
-        "MIXIN: mixin-forget-test"
-        "INSTANCE: sequence mixin-forget-test"
-        "GENERIC: mixin-forget-test-g ( x -- y )"
-        "M: mixin-forget-test mixin-forget-test-g ;"
-    } "\n" join <string-reader> "mixin-forget-test"
-    parse-stream drop
-] unit-test
-
-[ { } ] [ { } mixin-forget-test-g ] unit-test
-[ H{ } mixin-forget-test-g ] must-fail
-
-[ ] [
-    {
-        "USING: hashtables ;"
-        "IN: classes.tests"
-        "MIXIN: mixin-forget-test"
-        "INSTANCE: hashtable mixin-forget-test"
-        "GENERIC: mixin-forget-test-g ( x -- y )"
-        "M: mixin-forget-test mixin-forget-test-g ;"
-    } "\n" join <string-reader> "mixin-forget-test"
-    parse-stream drop
-] unit-test
-
-[ { } mixin-forget-test-g ] must-fail
-[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
+2 [
+    [ "mixin-forget-test" forget-source ] with-compilation-unit
+    
+    [ ] [
+        {
+            "USING: sequences ;"
+            "IN: classes.tests"
+            "MIXIN: mixin-forget-test"
+            "INSTANCE: sequence mixin-forget-test"
+            "GENERIC: mixin-forget-test-g ( x -- y )"
+            "M: mixin-forget-test mixin-forget-test-g ;"
+        } "\n" join <string-reader> "mixin-forget-test"
+        parse-stream drop
+    ] unit-test
+    
+    [ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
+    [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
+    
+    [ ] [
+        {
+            "USING: hashtables ;"
+            "IN: classes.tests"
+            "MIXIN: mixin-forget-test"
+            "INSTANCE: hashtable mixin-forget-test"
+            "GENERIC: mixin-forget-test-g ( x -- y )"
+            "M: mixin-forget-test mixin-forget-test-g ;"
+        } "\n" join <string-reader> "mixin-forget-test"
+        parse-stream drop
+    ] unit-test
+    
+    [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
+    [ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
+] times
 
 ! Method flattening interfered with mixin update
 MIXIN: flat-mx-1

core/classes/classes.factor

@@ -31,17 +31,9 @@ PREDICATE: class tuple-class
 
 PREDICATE: word predicate "predicating" word-prop >boolean ;
 
-: define-predicate* ( class predicate quot -- )
-    over [
-        dupd predicate-effect define-declared
-        2dup 1quotation "predicate" set-word-prop
-        swap "predicating" set-word-prop
-    ] [ 3drop ] if ;
-
 : define-predicate ( class quot -- )
-    over "forgotten" word-prop [ 2drop ] [
-        >r dup predicate-word r> define-predicate*
-    ] if ;
+    >r "predicate" word-prop first
+    r> predicate-effect define-declared ;
 
 : superclass ( class -- super )
     "superclass" word-prop ;
@@ -257,6 +249,8 @@ PRIVATE>
     over reset-class
     over deferred? [ over define-symbol ] when
     >r dup word-props r> union over set-word-props
+    dup predicate-word 2dup 1quotation "predicate" set-word-prop
+    over "predicating" set-word-prop
     t "class" set-word-prop ;
 
 GENERIC: update-predicate ( class -- )