From 93ad9cb096fa78e1e82244dedc729730b0945ea2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Mar 2008 17:20:28 -0500 Subject: [PATCH] Working on classes --- core/classes/classes-docs.factor | 21 ++-------- core/classes/classes-tests.factor | 66 +++++++++++++++---------------- core/classes/classes.factor | 14 ++----- 3 files changed, 40 insertions(+), 61 deletions(-) diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index df97a3eff5..1e71173153 100755 --- a/core/classes/classes-docs.factor +++ b/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 diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 640439312d..dbc1bcace2 100755 --- a/core/classes/classes-tests.factor +++ b/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 "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 "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 "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 "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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 48ddb2adf5..e60d3ba223 100755 --- a/core/classes/classes.factor +++ b/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 -- )