factor/library/generic/generic.factor

207 lines
5.7 KiB
Factor
Raw Normal View History

! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: arrays errors hashtables kernel kernel-internals lists
namespaces parser sequences strings words vectors math
math-internals ;
! A simple single-dispatch generic word system.
! Maps lists of builtin type numbers to class objects.
SYMBOL: typemap
2005-08-16 15:53:30 -04:00
2005-08-19 21:46:12 -04:00
! Global vector mapping type numbers to builtin class objects.
SYMBOL: builtins
: type>class ( n -- symbol ) builtins get nth ;
2005-05-16 01:15:48 -04:00
: predicate-word ( word -- word )
2005-07-28 18:20:31 -04:00
word-name "?" append create-in ;
: define-predicate ( class predicate quot -- )
#! predicate may be f, in which case it is ignored.
over [
dupd define-compound
2dup unit "predicate" set-word-prop
swap "predicating" set-word-prop
] [
3drop
2005-09-24 15:21:17 -04:00
] if ;
2005-07-28 18:20:31 -04:00
: superclass "superclass" word-prop ;
: members "members" word-prop ;
: (flatten) ( class -- )
2005-09-24 15:21:17 -04:00
dup members [ [ (flatten) ] each ] [ dup set ] ?if ;
: flatten ( class -- classes )
#! Outputs a sequence of classes whose union is this class.
[ (flatten) ] make-hash ;
: (types) ( class -- )
#! Only valid for a flattened class.
2005-09-18 23:22:58 -04:00
flatten [
car dup superclass
2005-09-24 15:21:17 -04:00
[ (types) ] [ "type" word-prop dup set ] ?if
2005-09-18 23:22:58 -04:00
] hash-each ;
2005-08-14 18:13:16 -04:00
: types ( class -- types )
2005-09-18 23:22:58 -04:00
[ (types) ] make-hash hash-keys ;
DEFER: class<
2005-07-31 23:38:33 -04:00
: superclass< ( cls1 cls2 -- ? )
2005-09-24 15:21:17 -04:00
>r superclass r> over [ class< ] [ 2drop f ] if ;
: (class<) ( cls1 cls2 -- ? )
[ flatten hash-keys ] 2apply
swap [ swap [ class< ] contains-with? ] all-with? ;
2005-08-14 23:26:40 -04:00
: class< ( cls1 cls2 -- ? )
#! Test if class1 is a subclass of class2.
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over flatten hash-size 0 = ] [ 2drop t ] }
{ [ over superclass ] [ >r superclass r> class< ] }
{ [ dup superclass ] [ superclass< ] }
{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
{ [ t ] [ (class<) ] }
} cond ;
2005-08-14 23:26:40 -04:00
: class-compare ( cls1 cls2 -- -1/0/1 )
2005-09-24 15:21:17 -04:00
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
2004-12-29 18:01:23 -05:00
: methods ( generic -- alist )
"methods" word-prop hash>alist [ 2car class-compare ] sort ;
2005-04-24 20:57:37 -04:00
: order ( generic -- list )
methods [ car ] map ;
PREDICATE: compound generic ( word -- ? )
"combination" word-prop ;
M: generic definer drop \ G: ;
2005-04-24 20:57:37 -04:00
: make-generic ( word -- )
2005-08-23 15:50:32 -04:00
dup dup "combination" word-prop call define-compound ;
: class? ( word -- ? ) "class" word-prop ;
: check-method ( class generic -- )
dup generic? [
dup word-name " is not a generic word" append throw
] unless
over "class" word-prop [
over word-name " is not a class" append throw
] unless 2drop ;
: define-method ( definition class generic -- )
>r reintern r> 2dup check-method
[ "methods" word-prop set-hash ] keep make-generic ;
: forget-method ( class generic -- )
[ "methods" word-prop remove-hash ] keep make-generic ;
2004-12-29 18:01:23 -05:00
: init-methods ( word -- )
2005-08-22 14:29:43 -04:00
dup "methods" word-prop
[ drop ] [ H{ } clone "methods" set-word-prop ] if ;
2004-12-29 18:01:23 -05:00
! Defining generic words
2005-08-22 15:33:18 -04:00
: bootstrap-combination ( quot -- quot )
#! Bootstrap hack.
global [
[
dup word? [
dup word-name swap word-vocabulary lookup
2005-08-22 15:33:18 -04:00
] when
] map
] bind ;
2005-08-22 14:29:43 -04:00
: define-generic* ( word combination -- )
2005-08-22 15:33:18 -04:00
bootstrap-combination
2005-08-22 14:29:43 -04:00
dupd "combination" set-word-prop
dup init-methods make-generic ;
: lookup-union ( class-set -- class )
#! The class set is a hashtable with equal keys/values.
typemap get hash [ object ] unless* ;
: (builtin-supertypes) ( class -- )
dup members [
[ (builtin-supertypes) ] each
2005-07-31 23:38:33 -04:00
] [
dup superclass [
(builtin-supertypes)
2005-07-31 23:38:33 -04:00
] [
dup set
2005-09-24 15:21:17 -04:00
] ?if
] ?if ;
: builtin-supertypes ( class -- classes )
#! Outputs a sequence of builtin classes whose union is the
#! smallest union of builtin classes that contains this
#! class.
[ (builtin-supertypes) ] make-hash ;
: (class-and) ( class class -- class )
[ builtin-supertypes ] 2apply hash-intersect lookup-union ;
: class-and ( class class -- class )
2005-03-07 22:11:36 -05:00
#! Return a class that is a subclass of both, or null in
#! the degenerate case.
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ t ] [ (class-and) ] }
} cond ;
2005-08-16 15:53:30 -04:00
: classes-intersect? ( class class -- ? )
class-and flatten hash-size 0 > ;
2005-08-16 15:53:30 -04:00
: min-class ( class seq -- class/f )
#! Is this class the smallest class in the sequence?
2005-08-16 15:53:30 -04:00
[ dupd classes-intersect? ] subset
[ class-compare neg ] sort
2005-09-24 15:21:17 -04:00
tuck [ class< ] all-with? [ first ] [ drop f ] if ;
: define-class ( class -- )
dup t "class" set-word-prop
dup flatten typemap get set-hash ;
: implementors ( class -- list )
#! Find a list of generics that implement a method
#! specializing on this class.
[ "methods" word-prop ?hash ] word-subset-with ;
: classes ( -- list )
#! Output a list of all defined classes.
[ class? ] word-subset ;
! 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
2005-09-24 15:21:17 -04:00
[ \ dup , % , [ drop f ] , \ if , ] [ ] make
define-predicate ;
PREDICATE: word predicate "definition" word-prop ;
! Union classes for dispatch on multiple classes.
: union-predicate ( members -- list )
[
"predicate" word-prop \ dup swons [ drop t ] cons
] map [ drop f ] swap alist>quot ;
: set-members ( class members -- )
[ reintern ] map "members" set-word-prop ;
: define-union ( class predicate members -- )
#! We have to turn the f object into the f word, same for t.
3dup nip set-members pick define-class
union-predicate define-predicate ;
PREDICATE: word union members ;