diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 859b6a95d5..56dda6f904 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -119,7 +119,7 @@ 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 +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:" @@ -132,6 +132,13 @@ HELP: define-predicate } $low-level-note ; +HELP: define-predicate +{ $values { "class" class } { "quot" "a quotation" } } +{ $description + "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "." +} +$low-level-note ; + HELP: superclass { $values { "class" class } { "super" class } } { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 345676e106..70088f2b03 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -31,13 +31,16 @@ PREDICATE: class tuple-class PREDICATE: word predicate "predicating" word-prop >boolean ; -: define-predicate ( class predicate quot -- ) +: define-predicate* ( class predicate quot -- ) over [ dupd predicate-effect define-declared 2dup 1quotation "predicate" set-word-prop swap "predicating" set-word-prop - ] [ - 3drop + ] [ 3drop ] if ; + +: define-predicate ( class quot -- ) + over "forgotten" word-prop [ 2drop ] [ + >r dup predicate-word r> define-predicate* ] if ; : superclass ( class -- super ) diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor old mode 100644 new mode 100755 index a7270869c5..6d1c727ee2 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -16,7 +16,7 @@ PREDICATE: class predicate-class : define-predicate-class ( superclass class definition -- ) >r dup f roll predicate-class define-class r> dupd "predicate-definition" set-word-prop - dup predicate-word over predicate-quot define-predicate ; + dup predicate-quot define-predicate ; M: predicate-class reset-class { diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 332903d36b..dcc05e8160 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -31,9 +31,7 @@ PREDICATE: class union-class ] if ; : define-union-predicate ( class -- ) - dup predicate-word - over members union-predicate-quot - define-predicate ; + dup members union-predicate-quot define-predicate ; M: union-class update-predicate define-union-predicate ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 306c7f4726..ea74645525 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -66,9 +66,7 @@ M: tuple-class tuple-size "slot-names" word-prop length 2 + ; PRIVATE> : define-tuple-predicate ( class -- ) - dup predicate-word - over [ tuple-class-eq? ] curry - define-predicate ; + dup [ tuple-class-eq? ] curry define-predicate ; : delegate-slot-spec T{ slot-spec f diff --git a/core/words/words.factor b/core/words/words.factor index 091bd3467d..efb3d06a9b 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -172,7 +172,9 @@ SYMBOL: changed-words gensym dup rot define ; : reveal ( word -- ) - dup word-name over word-vocabulary vocab-words set-at ; + dup word-name over word-vocabulary dup vocab-words + [ ] [ no-vocab ] ?if + set-at ; TUPLE: check-create name vocab ;