Generic word system cleanup
slava
parent
e4ca1e2bd3
commit
1158ab413b
|
|
@ -1,7 +1,6 @@
|
|||
+ 0.84:
|
||||
|
||||
- windows native i/o
|
||||
- fix contribs: parser-combinators, boids, automata, space-invaders
|
||||
- fix contribs: boids, automata, space-invaders
|
||||
- sometimes darcs get fails with the httpd
|
||||
- gdb triggers 'mutliple i/o ops on port' error
|
||||
- "localhost" 50 <client> won't fail
|
||||
|
|
@ -30,10 +29,6 @@
|
|||
- offer to remove generic words which are not called and have no
|
||||
methods
|
||||
- forgetting a tuple class should forget the constructor
|
||||
- see by itself only shows the G: def
|
||||
- { class generic } see supports forms:
|
||||
{ f generic } to show all methods
|
||||
{ class f } to show all methods
|
||||
- methods: remember their file/line
|
||||
- { class generic } jedit, reload DTRT
|
||||
- T{ link f "foo" "bar" } see
|
||||
|
|
@ -46,6 +41,7 @@
|
|||
|
||||
+ ui:
|
||||
|
||||
- we have trouble drawing rectangles
|
||||
- the UI listener has a shitty design. perhaps it should not call out
|
||||
to the real listener.
|
||||
- remaining walker tasks:
|
||||
|
|
|
|||
|
|
@ -82,7 +82,9 @@ sequences vectors words ;
|
|||
|
||||
"/library/syntax/early-parser.factor"
|
||||
|
||||
"/library/generic/classes.factor"
|
||||
"/library/generic/generic.factor"
|
||||
"/library/generic/methods.factor"
|
||||
"/library/generic/standard-combination.factor"
|
||||
"/library/generic/slots.factor"
|
||||
"/library/generic/math-combination.factor"
|
||||
|
|
@ -253,7 +255,9 @@ sequences vectors words ;
|
|||
"/library/compiler/inference/inference.facts"
|
||||
"/library/compiler/compiler.facts"
|
||||
"/library/generic/early-generic.facts"
|
||||
"/library/generic/classes.facts"
|
||||
"/library/generic/generic.facts"
|
||||
"/library/generic/methods.facts"
|
||||
"/library/generic/math-combination.facts"
|
||||
"/library/generic/slots.facts"
|
||||
"/library/generic/standard-combination.facts"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,147 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: generic
|
||||
USING: arrays errors hashtables kernel kernel-internals
|
||||
namespaces parser sequences strings words vectors math
|
||||
math-internals ;
|
||||
|
||||
PREDICATE: word class "class" word-prop ;
|
||||
|
||||
: classes ( -- list ) [ class? ] word-subset ;
|
||||
|
||||
SYMBOL: typemap
|
||||
SYMBOL: builtins
|
||||
|
||||
: type>class ( n -- symbol ) builtins get nth ;
|
||||
|
||||
: predicate-word ( word -- word )
|
||||
word-name "?" append create-in ;
|
||||
|
||||
: define-predicate ( class predicate quot -- )
|
||||
over [
|
||||
dupd define-compound
|
||||
2dup unit "predicate" set-word-prop
|
||||
swap "predicating" set-word-prop
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: superclass "superclass" word-prop ;
|
||||
|
||||
: members "members" word-prop ;
|
||||
|
||||
: (flatten-class) ( class -- )
|
||||
dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
|
||||
|
||||
: flatten-class ( class -- classes )
|
||||
[ (flatten-class) ] make-hash ;
|
||||
|
||||
: (types) ( class -- )
|
||||
flatten-class [
|
||||
drop dup superclass
|
||||
[ (types) ] [ "type" word-prop dup set ] ?if
|
||||
] hash-each ;
|
||||
|
||||
: types ( class -- types )
|
||||
[ (types) ] make-hash hash-keys natural-sort ;
|
||||
|
||||
DEFER: (class<)
|
||||
|
||||
: superclass< ( cls1 cls2 -- ? )
|
||||
>r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
|
||||
|
||||
: union-class< ( cls1 cls2 -- ? )
|
||||
[ flatten-class ] 2apply hash-keys swap
|
||||
[ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
|
||||
|
||||
: class-empty? ( class -- ? )
|
||||
members dup [ empty? ] when ;
|
||||
|
||||
: (class<) ( cls1 cls2 -- ? )
|
||||
{
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ over class-empty? ] [ 2drop t ] }
|
||||
{ [ 2dup superclass< ] [ 2drop t ] }
|
||||
{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
|
||||
{ [ t ] [ union-class< ] }
|
||||
} cond ;
|
||||
|
||||
SYMBOL: class<cache
|
||||
|
||||
: class< ( cls1 cls2 -- ? )
|
||||
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
|
||||
|
||||
: smaller-classes ( class seq -- )
|
||||
[ swap (class<) ] subset-with ;
|
||||
|
||||
: make-class<cache ( -- hash )
|
||||
classes dup [
|
||||
2dup swap smaller-classes [ dup ] map>hash
|
||||
] map>hash nip ;
|
||||
|
||||
: with-class<cache ( quot -- )
|
||||
[ make-class<cache class<cache set call ] with-scope ;
|
||||
inline
|
||||
|
||||
: class-compare ( cls1 cls2 -- -1/0/1 )
|
||||
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
|
||||
|
||||
: lookup-union ( class-set -- class )
|
||||
typemap get hash [ object ] unless* ;
|
||||
|
||||
: types* ( class -- hash ) types [ type>class dup ] map>hash ;
|
||||
|
||||
: (class-and) ( class class -- class )
|
||||
[ types* ] 2apply hash-intersect lookup-union ;
|
||||
|
||||
: class-and ( class class -- class )
|
||||
{
|
||||
{ [ 2dup class< ] [ drop ] }
|
||||
{ [ 2dup swap class< ] [ nip ] }
|
||||
{ [ t ] [ (class-and) ] }
|
||||
} cond ;
|
||||
|
||||
: classes-intersect? ( class class -- ? )
|
||||
class-and class-empty? not ;
|
||||
|
||||
: min-class ( class seq -- class/f )
|
||||
[ dupd classes-intersect? ] subset dup empty? [
|
||||
2drop f
|
||||
] [
|
||||
tuck [ class< ] all-with? [ peek ] [ drop f ] if
|
||||
] if ;
|
||||
|
||||
: class-forget-hook ( class flattened -- )
|
||||
[ typemap get remove-hash ] curry
|
||||
"forget-hook" set-word-prop ;
|
||||
|
||||
: define-class ( class -- )
|
||||
dup t "class" set-word-prop
|
||||
dup H{ } clone "class<" set-word-prop
|
||||
dup flatten-class
|
||||
2dup class-forget-hook
|
||||
typemap get set-hash ;
|
||||
|
||||
! Predicate classes for generalized predicate dispatch.
|
||||
: define-predicate-class ( class predicate definition -- )
|
||||
pick define-class
|
||||
3dup nip "definition" set-word-prop
|
||||
pick superclass "predicate" word-prop
|
||||
[ \ dup , % , [ drop f ] , \ if , ] [ ] make
|
||||
define-predicate ;
|
||||
|
||||
PREDICATE: word predicate "definition" word-prop ;
|
||||
|
||||
! Union classes for dispatch on multiple classes.
|
||||
: union-predicate ( members -- list )
|
||||
[ dup ] swap [ "predicate" word-prop append ] map-with
|
||||
[ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
|
||||
|
||||
: set-members ( class members -- )
|
||||
[ bootstrap-word ] map "members" set-word-prop ;
|
||||
|
||||
: define-union ( class predicate members -- )
|
||||
3dup nip set-members pick define-class
|
||||
union-predicate define-predicate ;
|
||||
|
||||
PREDICATE: word union members ;
|
||||
|
|
@ -0,0 +1,139 @@
|
|||
USING: generic help kernel kernel-internals ;
|
||||
|
||||
HELP: typemap f
|
||||
{ $description "Global variable. Hashtable mapping unions to class words." }
|
||||
{ $see-also class-and } ;
|
||||
|
||||
HELP: builtins f
|
||||
{ $description "Global variable. Vector mapping type numbers to builtin class words." } ;
|
||||
|
||||
HELP: object f
|
||||
{ $description
|
||||
"The class of all objects. If a generic word defines a method specializing on this class, the method is used as a fallback, if no other applicable method is found. For instance:"
|
||||
{ $code "GENERIC: enclose" "M: number enclose 1array ;" "M: object enclose ;" }
|
||||
} ;
|
||||
|
||||
HELP: null f
|
||||
{ $description
|
||||
"The canonical empty class with no instances."
|
||||
} ;
|
||||
|
||||
|
||||
HELP: type>class "( n -- class )"
|
||||
{ $values { "n" "a non-negative integer" } { "class" "a class word" } }
|
||||
{ $description "Outputs a builtin class whose instances are precisely those of a builtin type." }
|
||||
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
|
||||
|
||||
HELP: predicate-word "( word -- predicate )"
|
||||
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
|
||||
{ $description "Suffixes \"?\" to the name of " { $snippet "word" } " and creates a word with that name in the current vocabulary." } ;
|
||||
|
||||
HELP: define-predicate "( class predicate quot -- )"
|
||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "quot" "a quotation" } }
|
||||
{ $description
|
||||
"Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that two 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" }
|
||||
}
|
||||
"These properties allow the method combination code to generate method dispatch logic."
|
||||
}
|
||||
$low-level-note ;
|
||||
|
||||
HELP: superclass "( class -- super )"
|
||||
{ $values { "class" "a class word" } { "super" "a class word" } }
|
||||
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
|
||||
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate classes (see " { $link POSTPONE: PREDICATE: } ").." } ;
|
||||
|
||||
HELP: members "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of union members, or " { $link f } } }
|
||||
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of members, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: flatten-class "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of classes" } }
|
||||
{ $description "Outputs a sequence of classes whose union is the given class. Unless the given class is a union class, the output is just a singleton sequence consisting of the given class." } ;
|
||||
|
||||
HELP: types "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of integers" } }
|
||||
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
|
||||
|
||||
HELP: class-empty? "( class -- ? )"
|
||||
{ $values { "class" "a class" } }
|
||||
{ $description "Tests if a class is a union class with no members." }
|
||||
{ $examples { $example "null class-empty? ." "t" } } ;
|
||||
|
||||
HELP: class< "( class1 class2 -- ? )"
|
||||
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
|
||||
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
|
||||
|
||||
HELP: class-compare "( class1 class2 -- n )"
|
||||
{ $values { "class1" "a class" } { "class2" "a class" } { "n" "an integer" } }
|
||||
{ $description "Compares two classes, with the sign of the result indicating their sort order." }
|
||||
{ $notes "This word is used to sort sequences of classes." }
|
||||
{ $see-also methods order } ;
|
||||
|
||||
HELP: ?make-generic "( word -- )"
|
||||
{ $values { "word" "a generic word" } }
|
||||
{ $description "Regenerates the definition of a generic word, unless bootstrap is in progress, in which case nothing is done. This avoids regenerating generic words multiple times during bootstrap as methods are defined. Instead, all generic words are built once at the end of the process, resulting in a performance improvement." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: init-methods "( word -- )"
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Prepare to define a generic word." } ;
|
||||
|
||||
HELP: define-generic* "( word combination -- )"
|
||||
{ $values { "word" "a word" } { "combination" "a quotation with stack effect " { $snippet "( word -- quot )" } } }
|
||||
{ $description "Defines a generic word with the specified method combination. If the word is already a generic word, existing methods are retained." }
|
||||
{ $see-also POSTPONE: G: define-generic } ;
|
||||
|
||||
HELP: lookup-union "( classes -- class )"
|
||||
{ $values { "classes" "a hashtable where keys are classes and values equal keys" } { "class" "a class word" } }
|
||||
{ $description "Outputs a class that is the union of the given classes. If no precise match is found, outputs " { $link object } ", even if the given set is not an exhaustive cover all classes." } ;
|
||||
|
||||
HELP: types* "( class -- classes )"
|
||||
{ $values { "class" "a class word" } { "classes" "a hashtable where keys are classes and values equal keys" } }
|
||||
{ $description "Outputs a sequence of builtin classes whose instances can possibly be instances of the given class." } ;
|
||||
|
||||
HELP: class-and "( class1 class2 -- class )"
|
||||
{ $values { "class1" "a class word" } { "class2" "a class word" } { "class" "a class word" } }
|
||||
{ $description "Outputs a class whose instances are instances of both input classes. If the intersection is non-empty but no class with those members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
|
||||
|
||||
HELP: classes-intersect? "( class1 class2 -- ? )"
|
||||
{ $values { "class1" "a class word" } { "class2" "a class word" } { "?" "a boolean" } }
|
||||
{ $description "Tests if two classes have a non-empty intersection." } ;
|
||||
|
||||
HELP: min-class "( class seq -- class/f )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
|
||||
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: define-class "( class -- )"
|
||||
{ $values { "class" "a class word" } }
|
||||
{ $description "Sets a property indicating this is a class word, and registers the class in the global union lookup map." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: classes "( -- seq )"
|
||||
{ $values { "seq" "a sequence of class words" } }
|
||||
{ $description "Finds all class words in the dictionary." } ;
|
||||
|
||||
HELP: define-predicate-class "( class predicate definition -- )"
|
||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
|
||||
{ $description "Defines a predicate class. The superclass of " { $snippet "class" } " must already be set." }
|
||||
{ $see-also POSTPONE: PREDICATE: } ;
|
||||
|
||||
HELP: predicate f
|
||||
{ $description "The class of predicate class words." }
|
||||
{ $see-also POSTPONE: PREDICATE: } ;
|
||||
|
||||
HELP: union-predicate "( seq -- quot )"
|
||||
{ $values { "seq" "a sequence of class words" } { "quot" "a quotation with stack effect " { $snippet "( object -- ? )" } } }
|
||||
{ $description "Outputs a quotation for testing of an object is an instance of one of the given classes." } ;
|
||||
|
||||
HELP: define-union "( class predicate members -- )"
|
||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "members" "a sequence of class words" } }
|
||||
{ $description "Defines a union class with specified members." }
|
||||
{ $see-also POSTPONE: UNION: } ;
|
||||
|
||||
HELP: union f
|
||||
{ $description "The class of union class words." }
|
||||
{ $see-also POSTPONE: UNION: } ;
|
||||
|
|
@ -1,97 +1,7 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: generic
|
||||
USING: arrays errors hashtables kernel kernel-internals
|
||||
namespaces parser sequences strings words vectors math
|
||||
math-internals ;
|
||||
|
||||
: class? ( word -- ? ) "class" word-prop ;
|
||||
|
||||
: classes ( -- list ) [ class? ] word-subset ;
|
||||
|
||||
SYMBOL: typemap
|
||||
SYMBOL: builtins
|
||||
|
||||
: type>class ( n -- symbol ) builtins get nth ;
|
||||
|
||||
: predicate-word ( word -- word )
|
||||
word-name "?" append create-in ;
|
||||
|
||||
: define-predicate ( class predicate quot -- )
|
||||
over [
|
||||
dupd define-compound
|
||||
2dup unit "predicate" set-word-prop
|
||||
swap "predicating" set-word-prop
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: superclass "superclass" word-prop ;
|
||||
|
||||
: members "members" word-prop ;
|
||||
|
||||
: (flatten-class) ( class -- )
|
||||
dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
|
||||
|
||||
: flatten-class ( class -- classes )
|
||||
[ (flatten-class) ] make-hash ;
|
||||
|
||||
: (types) ( class -- )
|
||||
flatten-class [
|
||||
drop dup superclass
|
||||
[ (types) ] [ "type" word-prop dup set ] ?if
|
||||
] hash-each ;
|
||||
|
||||
: types ( class -- types )
|
||||
[ (types) ] make-hash hash-keys natural-sort ;
|
||||
|
||||
DEFER: (class<)
|
||||
|
||||
: superclass< ( cls1 cls2 -- ? )
|
||||
>r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
|
||||
|
||||
: union-class< ( cls1 cls2 -- ? )
|
||||
[ flatten-class ] 2apply hash-keys swap
|
||||
[ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
|
||||
|
||||
: class-empty? ( class -- ? )
|
||||
members dup [ empty? ] when ;
|
||||
|
||||
: (class<) ( cls1 cls2 -- ? )
|
||||
{
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ over class-empty? ] [ 2drop t ] }
|
||||
{ [ 2dup superclass< ] [ 2drop t ] }
|
||||
{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
|
||||
{ [ t ] [ union-class< ] }
|
||||
} cond ;
|
||||
|
||||
SYMBOL: class<cache
|
||||
|
||||
: class< ( cls1 cls2 -- ? )
|
||||
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
|
||||
|
||||
: smaller-classes ( class seq -- )
|
||||
[ swap (class<) ] subset-with ;
|
||||
|
||||
: make-class<cache ( -- hash )
|
||||
classes dup [
|
||||
2dup swap smaller-classes [ dup ] map>hash
|
||||
] map>hash nip ;
|
||||
|
||||
: with-class<cache ( quot -- )
|
||||
[ make-class<cache class<cache set call ] with-scope ;
|
||||
inline
|
||||
|
||||
: class-compare ( cls1 cls2 -- -1/0/1 )
|
||||
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
|
||||
|
||||
: methods ( generic -- alist )
|
||||
"methods" word-prop hash>alist
|
||||
[ [ first ] 2apply class-compare ] sort ;
|
||||
|
||||
: order ( generic -- list )
|
||||
"methods" word-prop hash-keys [ class-compare ] sort ;
|
||||
USING: words kernel sequences namespaces ;
|
||||
|
||||
PREDICATE: compound generic ( word -- ? )
|
||||
"combination" word-prop ;
|
||||
|
|
@ -101,27 +11,10 @@ M: generic definer drop \ G: ;
|
|||
: make-generic ( word -- )
|
||||
dup dup "combination" word-prop call define-compound ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
: check-method ( class generic -- class generic )
|
||||
dup generic? [ <check-method> throw ] unless
|
||||
over class? [ <check-method> throw ] unless ;
|
||||
|
||||
: ?make-generic ( word -- )
|
||||
bootstrapping? get
|
||||
[ [ ] define-compound ] [ make-generic ] if ;
|
||||
|
||||
: with-methods ( word quot -- | quot: methods -- )
|
||||
swap [ "methods" word-prop swap call ] keep ?make-generic ;
|
||||
inline
|
||||
|
||||
: define-method ( definition class generic -- )
|
||||
>r bootstrap-word r> check-method
|
||||
[ set-hash ] with-methods ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
[ remove-hash ] with-methods ;
|
||||
|
||||
: init-methods ( word -- )
|
||||
dup "methods" word-prop
|
||||
[ drop ] [ H{ } clone "methods" set-word-prop ] if ;
|
||||
|
|
@ -135,66 +28,3 @@ TUPLE: check-method class generic ;
|
|||
bootstrap-combination
|
||||
dupd "combination" set-word-prop
|
||||
dup init-methods ?make-generic ;
|
||||
|
||||
: lookup-union ( class-set -- class )
|
||||
typemap get hash [ object ] unless* ;
|
||||
|
||||
: types* ( class -- hash ) types [ type>class dup ] map>hash ;
|
||||
|
||||
: (class-and) ( class class -- class )
|
||||
[ types* ] 2apply hash-intersect lookup-union ;
|
||||
|
||||
: class-and ( class class -- class )
|
||||
{
|
||||
{ [ 2dup class< ] [ drop ] }
|
||||
{ [ 2dup swap class< ] [ nip ] }
|
||||
{ [ t ] [ (class-and) ] }
|
||||
} cond ;
|
||||
|
||||
: classes-intersect? ( class class -- ? )
|
||||
class-and class-empty? not ;
|
||||
|
||||
: min-class ( class seq -- class/f )
|
||||
[ dupd classes-intersect? ] subset dup empty? [
|
||||
2drop f
|
||||
] [
|
||||
tuck [ class< ] all-with? [ peek ] [ drop f ] if
|
||||
] if ;
|
||||
|
||||
: class-forget-hook ( class flattened -- )
|
||||
[ typemap get remove-hash ] curry
|
||||
"forget-hook" set-word-prop ;
|
||||
|
||||
: define-class ( class -- )
|
||||
dup t "class" set-word-prop
|
||||
dup H{ } clone "class<" set-word-prop
|
||||
dup flatten-class
|
||||
2dup class-forget-hook
|
||||
typemap get set-hash ;
|
||||
|
||||
: implementors ( class -- list )
|
||||
[ "methods" word-prop ?hash* nip ] word-subset-with ;
|
||||
|
||||
! Predicate classes for generalized predicate dispatch.
|
||||
: define-predicate-class ( class predicate definition -- )
|
||||
pick define-class
|
||||
3dup nip "definition" set-word-prop
|
||||
pick superclass "predicate" word-prop
|
||||
[ \ dup , % , [ drop f ] , \ if , ] [ ] make
|
||||
define-predicate ;
|
||||
|
||||
PREDICATE: word predicate "definition" word-prop ;
|
||||
|
||||
! Union classes for dispatch on multiple classes.
|
||||
: union-predicate ( members -- list )
|
||||
[ dup ] swap [ "predicate" word-prop append ] map-with
|
||||
[ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
|
||||
|
||||
: set-members ( class members -- )
|
||||
[ bootstrap-word ] map "members" set-word-prop ;
|
||||
|
||||
: define-union ( class predicate members -- )
|
||||
3dup nip set-members pick define-class
|
||||
union-predicate define-predicate ;
|
||||
|
||||
PREDICATE: word union members ;
|
||||
|
|
|
|||
|
|
@ -1,77 +1,5 @@
|
|||
USING: generic help kernel kernel-internals ;
|
||||
|
||||
HELP: typemap f
|
||||
{ $description "Global variable. Hashtable mapping unions to class words." }
|
||||
{ $see-also class-and } ;
|
||||
|
||||
HELP: builtins f
|
||||
{ $description "Global variable. Vector mapping type numbers to builtin class words." } ;
|
||||
|
||||
HELP: object f
|
||||
{ $description
|
||||
"The class of all objects. If a generic word defines a method specializing on this class, the method is used as a fallback, if no other applicable method is found. For instance:"
|
||||
{ $code "GENERIC: enclose" "M: number enclose 1array ;" "M: object enclose ;" }
|
||||
} ;
|
||||
|
||||
HELP: null f
|
||||
{ $description
|
||||
"The canonical empty class with no instances."
|
||||
} ;
|
||||
|
||||
|
||||
HELP: type>class "( n -- class )"
|
||||
{ $values { "n" "a non-negative integer" } { "class" "a class word" } }
|
||||
{ $description "Outputs a builtin class whose instances are precisely those of a builtin type." }
|
||||
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
|
||||
|
||||
HELP: predicate-word "( word -- predicate )"
|
||||
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
|
||||
{ $description "Suffixes \"?\" to the name of " { $snippet "word" } " and creates a word with that name in the current vocabulary." } ;
|
||||
|
||||
HELP: define-predicate "( class predicate quot -- )"
|
||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "quot" "a quotation" } }
|
||||
{ $description
|
||||
"Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that two 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" }
|
||||
}
|
||||
"These properties allow the method combination code to generate method dispatch logic."
|
||||
}
|
||||
$low-level-note ;
|
||||
|
||||
HELP: superclass "( class -- super )"
|
||||
{ $values { "class" "a class word" } { "super" "a class word" } }
|
||||
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
|
||||
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate classes (see " { $link POSTPONE: PREDICATE: } ").." } ;
|
||||
|
||||
HELP: members "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of union members, or " { $link f } } }
|
||||
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of members, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: flatten-class "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of classes" } }
|
||||
{ $description "Outputs a sequence of classes whose union is the given class. Unless the given class is a union class, the output is just a singleton sequence consisting of the given class." } ;
|
||||
|
||||
HELP: types "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of integers" } }
|
||||
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
|
||||
|
||||
HELP: class-empty? "( class -- ? )"
|
||||
{ $values { "class" "a class" } }
|
||||
{ $description "Tests if a class is a union class with no members." }
|
||||
{ $examples { $example "null class-empty? ." "t" } } ;
|
||||
|
||||
HELP: class< "( class1 class2 -- ? )"
|
||||
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
|
||||
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
|
||||
|
||||
HELP: class-compare "( class1 class2 -- n )"
|
||||
{ $values { "class1" "a class" } { "class2" "a class" } { "n" "an integer" } }
|
||||
{ $description "Compares two classes, with the sign of the result indicating their sort order." }
|
||||
{ $notes "This word is used to sort sequences of classes." }
|
||||
{ $see-also methods order } ;
|
||||
IN: generic
|
||||
USING: help ;
|
||||
|
||||
HELP: methods "( word -- alist )"
|
||||
{ $values { "word" "a generic word" } { "alist" "a sequence of pairs" } }
|
||||
|
|
@ -89,90 +17,3 @@ HELP: make-generic "( word -- )"
|
|||
{ $values { "word" "a generic word" } }
|
||||
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: check-method "( class generic -- class generic )"
|
||||
{ $values { "class" "a class word" } { "generic" "a generic word" } }
|
||||
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
|
||||
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
|
||||
|
||||
HELP: ?make-generic "( word -- )"
|
||||
{ $values { "word" "a generic word" } }
|
||||
{ $description "Regenerates the definition of a generic word, unless bootstrap is in progress, in which case nothing is done. This avoids regenerating generic words multiple times during bootstrap as methods are defined. Instead, all generic words are built once at the end of the process, resulting in a performance improvement." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: with-methods "( word quot -- )"
|
||||
{ $values { "word" "a generic word" } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
|
||||
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: define-method "( quot class generic -- )"
|
||||
{ $values { "quot" "a quotation" } { "class" "a class word" } { "generic" "a generic word" } }
|
||||
{ $description "Defines a method on " { $snippet "generic" } " associating " { $snippet "class" } " with " { $snippet "quot" } "." } ;
|
||||
|
||||
HELP: forget-method "( class generic -- )"
|
||||
{ $values { "class" "a class word" } { "generic" "a generic word" } }
|
||||
{ $description "Removes the method definition for " { $snippet "class" } " from " { $snippet "generic" } "." } ;
|
||||
|
||||
HELP: init-methods "( word -- )"
|
||||
{ $values { "word" "a word" } }
|
||||
{ $description "Prepare to define a generic word." } ;
|
||||
|
||||
HELP: define-generic* "( word combination -- )"
|
||||
{ $values { "word" "a word" } { "combination" "a quotation with stack effect " { $snippet "( word -- quot )" } } }
|
||||
{ $description "Defines a generic word with the specified method combination. If the word is already a generic word, existing methods are retained." }
|
||||
{ $see-also POSTPONE: G: define-generic } ;
|
||||
|
||||
HELP: lookup-union "( classes -- class )"
|
||||
{ $values { "classes" "a hashtable where keys are classes and values equal keys" } { "class" "a class word" } }
|
||||
{ $description "Outputs a class that is the union of the given classes. If no precise match is found, outputs " { $link object } ", even if the given set is not an exhaustive cover all classes." } ;
|
||||
|
||||
HELP: types* "( class -- classes )"
|
||||
{ $values { "class" "a class word" } { "classes" "a hashtable where keys are classes and values equal keys" } }
|
||||
{ $description "Outputs a sequence of builtin classes whose instances can possibly be instances of the given class." } ;
|
||||
|
||||
HELP: class-and "( class1 class2 -- class )"
|
||||
{ $values { "class1" "a class word" } { "class2" "a class word" } { "class" "a class word" } }
|
||||
{ $description "Outputs a class whose instances are instances of both input classes. If the intersection is non-empty but no class with those members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
|
||||
|
||||
HELP: classes-intersect? "( class1 class2 -- ? )"
|
||||
{ $values { "class1" "a class word" } { "class2" "a class word" } { "?" "a boolean" } }
|
||||
{ $description "Tests if two classes have a non-empty intersection." } ;
|
||||
|
||||
HELP: min-class "( class seq -- class/f )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
|
||||
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
|
||||
|
||||
HELP: define-class "( class -- )"
|
||||
{ $values { "class" "a class word" } }
|
||||
{ $description "Sets a property indicating this is a class word, and registers the class in the global union lookup map." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: implementors "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of generic words" } }
|
||||
{ $description "Finds all generic words in the dictionary implementing methods for this class." } ;
|
||||
|
||||
HELP: classes "( -- seq )"
|
||||
{ $values { "seq" "a sequence of class words" } }
|
||||
{ $description "Finds all class words in the dictionary." } ;
|
||||
|
||||
HELP: define-predicate-class "( class predicate definition -- )"
|
||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
|
||||
{ $description "Defines a predicate class. The superclass of " { $snippet "class" } " must already be set." }
|
||||
{ $see-also POSTPONE: PREDICATE: } ;
|
||||
|
||||
HELP: predicate f
|
||||
{ $description "The class of predicate class words." }
|
||||
{ $see-also POSTPONE: PREDICATE: } ;
|
||||
|
||||
HELP: union-predicate "( seq -- quot )"
|
||||
{ $values { "seq" "a sequence of class words" } { "quot" "a quotation with stack effect " { $snippet "( object -- ? )" } } }
|
||||
{ $description "Outputs a quotation for testing of an object is an instance of one of the given classes." } ;
|
||||
|
||||
HELP: define-union "( class predicate members -- )"
|
||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "members" "a sequence of class words" } }
|
||||
{ $description "Defines a union class with specified members." }
|
||||
{ $see-also POSTPONE: UNION: } ;
|
||||
|
||||
HELP: union f
|
||||
{ $description "The class of union class words." }
|
||||
{ $see-also POSTPONE: UNION: } ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: generic
|
||||
USING: words hashtables sequences arrays errors kernel ;
|
||||
|
||||
: methods ( generic -- alist )
|
||||
"methods" word-prop hash>alist
|
||||
[ [ first ] 2apply class-compare ] sort ;
|
||||
|
||||
: order ( generic -- list )
|
||||
"methods" word-prop hash-keys [ class-compare ] sort ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
: check-method ( class generic -- class generic )
|
||||
dup generic? [ <check-method> throw ] unless
|
||||
over class? [ <check-method> throw ] unless ;
|
||||
|
||||
: with-methods ( word quot -- | quot: methods -- )
|
||||
swap [ "methods" word-prop swap call ] keep ?make-generic ;
|
||||
inline
|
||||
|
||||
: define-method ( definition class generic -- )
|
||||
>r bootstrap-word r> check-method
|
||||
[ set-hash ] with-methods ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
[ remove-hash ] with-methods ;
|
||||
|
||||
: implementors ( class -- list )
|
||||
[ "methods" word-prop ?hash* nip ] word-subset-with ;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
IN: generic
|
||||
USING: help ;
|
||||
|
||||
HELP: check-method "( class generic -- class generic )"
|
||||
{ $values { "class" "a class word" } { "generic" "a generic word" } }
|
||||
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
|
||||
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
|
||||
|
||||
HELP: with-methods "( word quot -- )"
|
||||
{ $values { "word" "a generic word" } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
|
||||
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: define-method "( quot class generic -- )"
|
||||
{ $values { "quot" "a quotation" } { "class" "a class word" } { "generic" "a generic word" } }
|
||||
{ $description "Defines a method on " { $snippet "generic" } " associating " { $snippet "class" } " with " { $snippet "quot" } "." } ;
|
||||
|
||||
HELP: forget-method "( class generic -- )"
|
||||
{ $values { "class" "a class word" } { "generic" "a generic word" } }
|
||||
{ $description "Removes the method definition for " { $snippet "class" } " from " { $snippet "generic" } "." } ;
|
||||
|
||||
HELP: implementors "( class -- seq )"
|
||||
{ $values { "class" "a class word" } { "seq" "a sequence of generic words" } }
|
||||
{ $description "Finds all generic words in the dictionary implementing methods for this class." } ;
|
||||
Loading…
Reference in New Issue