2005-01-29 16:39:30 -05:00
|
|
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2004-12-13 00:13:54 -05:00
|
|
|
IN: generic
|
2005-09-16 02:39:33 -04:00
|
|
|
USING: arrays errors hashtables kernel kernel-internals lists
|
2005-04-25 19:54:21 -04:00
|
|
|
namespaces parser sequences strings words vectors math
|
|
|
|
math-internals ;
|
2004-12-13 00:13:54 -05:00
|
|
|
|
|
|
|
! A simple single-dispatch generic word system.
|
|
|
|
|
2005-08-15 03:25:39 -04:00
|
|
|
! 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 ;
|
|
|
|
|
2005-08-03 18:47:32 -04:00
|
|
|
: define-predicate ( class predicate quot -- )
|
2005-09-09 22:34:24 -04:00
|
|
|
#! 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
|
|
|
|
2005-09-16 02:39:33 -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 ;
|
2005-09-16 02:39:33 -04:00
|
|
|
|
|
|
|
: 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 [
|
2005-11-27 17:45:48 -05:00
|
|
|
drop 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 ;
|
2004-12-13 00:13:54 -05:00
|
|
|
|
2005-08-14 18:13:16 -04:00
|
|
|
: types ( class -- types )
|
2005-09-18 23:22:58 -04:00
|
|
|
[ (types) ] make-hash hash-keys ;
|
2004-12-13 00:13:54 -05:00
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
DEFER: class<
|
2005-07-31 23:38:33 -04:00
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
: superclass< ( cls1 cls2 -- ? )
|
2005-12-03 17:34:59 -05:00
|
|
|
>r superclass r> 2dup and [ class< ] [ 2drop f ] if ;
|
2005-09-16 02:39:33 -04:00
|
|
|
|
2005-12-03 17:34:59 -05:00
|
|
|
: union-class< ( cls1 cls2 -- ? )
|
2005-12-25 21:05:31 -05:00
|
|
|
>r flatten r> flatten hash-keys swap
|
|
|
|
[ drop swap [ class< ] contains-with? ] hash-all-with? ;
|
|
|
|
|
|
|
|
: class-empty? ( class -- ? )
|
|
|
|
members dup [ empty? ] when ;
|
2005-08-14 23:26:40 -04:00
|
|
|
|
|
|
|
: class< ( cls1 cls2 -- ? )
|
|
|
|
#! Test if class1 is a subclass of class2.
|
2005-10-29 23:25:38 -04:00
|
|
|
{
|
|
|
|
{ [ 2dup eq? ] [ 2drop t ] }
|
2005-12-25 21:05:31 -05:00
|
|
|
{ [ over class-empty? ] [ 2drop t ] }
|
2005-12-03 17:34:59 -05:00
|
|
|
{ [ 2dup superclass< ] [ 2drop t ] }
|
2005-10-29 23:25:38 -04:00
|
|
|
{ [ 2dup [ members ] 2apply or not ] [ 2drop f ] }
|
2005-12-03 17:34:59 -05:00
|
|
|
{ [ t ] [ union-class< ] }
|
2005-10-29 23:25:38 -04:00
|
|
|
} cond ;
|
2005-08-14 23:26:40 -04:00
|
|
|
|
2005-08-13 23:39:46 -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 ;
|
2005-08-13 23:39:46 -04:00
|
|
|
|
2004-12-29 18:01:23 -05:00
|
|
|
: methods ( generic -- alist )
|
2005-11-27 17:45:48 -05:00
|
|
|
"methods" word-prop hash>alist
|
|
|
|
[ [ first ] 2apply class-compare ] sort ;
|
2004-12-18 23:18:32 -05:00
|
|
|
|
2005-04-24 20:57:37 -04:00
|
|
|
: order ( generic -- list )
|
2005-11-27 17:45:48 -05:00
|
|
|
"methods" word-prop hash-keys [ class-compare ] sort ;
|
2005-09-16 02:39:33 -04:00
|
|
|
|
|
|
|
PREDICATE: compound generic ( word -- ? )
|
|
|
|
"combination" word-prop ;
|
|
|
|
|
|
|
|
M: generic definer drop \ G: ;
|
2005-04-24 20:57:37 -04:00
|
|
|
|
2005-05-14 21:15:50 -04:00
|
|
|
: make-generic ( word -- )
|
2005-08-23 15:50:32 -04:00
|
|
|
dup dup "combination" word-prop call define-compound ;
|
2004-12-18 23:18:32 -05:00
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
: class? ( word -- ? ) "class" word-prop ;
|
|
|
|
|
|
|
|
: check-method ( class generic -- )
|
|
|
|
dup generic? [
|
|
|
|
dup word-name " is not a generic word" append throw
|
2005-04-25 19:56:56 -04:00
|
|
|
] unless
|
2005-09-16 02:39:33 -04:00
|
|
|
over "class" word-prop [
|
|
|
|
over word-name " is not a class" append throw
|
|
|
|
] unless 2drop ;
|
|
|
|
|
2005-12-19 23:18:15 -05:00
|
|
|
: ?make-generic ( word -- )
|
|
|
|
#! Unless we're bootstrapping, in which case generic words
|
|
|
|
#! are built as the last stage of bootstrap.
|
|
|
|
bootstrapping? get [
|
|
|
|
[ ] define-compound
|
|
|
|
] [
|
|
|
|
make-generic
|
|
|
|
] if ;
|
|
|
|
|
2005-11-24 19:02:20 -05:00
|
|
|
: with-methods ( word quot -- | quot: methods -- )
|
|
|
|
#! Applies a quotation to the method hash and regenerates
|
|
|
|
#! the generic.
|
2005-12-19 23:18:15 -05:00
|
|
|
swap [ "methods" word-prop swap call ] keep ?make-generic ;
|
2005-11-24 19:02:20 -05:00
|
|
|
inline
|
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
: define-method ( definition class generic -- )
|
2005-11-24 19:02:20 -05:00
|
|
|
>r bootstrap-word r> 2dup check-method
|
|
|
|
[ set-hash ] with-methods ;
|
2004-12-18 23:18:32 -05:00
|
|
|
|
2005-08-04 23:59:45 -04:00
|
|
|
: forget-method ( class generic -- )
|
2005-11-24 19:02:20 -05:00
|
|
|
[ remove-hash ] with-methods ;
|
2005-08-04 23:59:45 -04:00
|
|
|
|
2004-12-29 18:01:23 -05:00
|
|
|
: init-methods ( word -- )
|
2005-08-22 14:29:43 -04:00
|
|
|
dup "methods" word-prop
|
2005-10-29 23:25:38 -04:00
|
|
|
[ drop ] [ H{ } clone "methods" set-word-prop ] if ;
|
2004-12-29 18:01:23 -05:00
|
|
|
|
2004-12-13 00:13:54 -05:00
|
|
|
! Defining generic words
|
2005-08-22 15:33:18 -04:00
|
|
|
|
|
|
|
: bootstrap-combination ( quot -- quot )
|
|
|
|
#! Bootstrap hack.
|
2005-11-24 19:02:20 -05:00
|
|
|
global [ [ dup word? [ target-word ] when ] map ] bind ;
|
2005-08-22 15:33:18 -04:00
|
|
|
|
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
|
2005-12-19 23:18:15 -05:00
|
|
|
dup init-methods ?make-generic ;
|
2004-12-18 23:18:32 -05:00
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
: lookup-union ( class-set -- class )
|
|
|
|
#! The class set is a hashtable with equal keys/values.
|
|
|
|
typemap get hash [ object ] unless* ;
|
2005-02-24 20:52:17 -05:00
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
: (builtin-supertypes) ( class -- )
|
|
|
|
dup members [
|
|
|
|
[ (builtin-supertypes) ] each
|
2005-07-31 23:38:33 -04:00
|
|
|
] [
|
2005-12-19 23:18:15 -05:00
|
|
|
dup superclass [ (builtin-supertypes) ] [ dup set ] ?if
|
2005-09-24 15:21:17 -04:00
|
|
|
] ?if ;
|
2005-09-16 02:39:33 -04:00
|
|
|
|
|
|
|
: 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 ;
|
2004-12-23 02:14:40 -05:00
|
|
|
|
2004-12-23 16:37:16 -05:00
|
|
|
: 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.
|
2005-10-29 23:25:38 -04:00
|
|
|
{
|
|
|
|
{ [ 2dup class< ] [ drop ] }
|
|
|
|
{ [ 2dup swap class< ] [ nip ] }
|
|
|
|
{ [ t ] [ (class-and) ] }
|
|
|
|
} cond ;
|
2004-12-23 02:14:40 -05:00
|
|
|
|
2005-08-16 15:53:30 -04:00
|
|
|
: classes-intersect? ( class class -- ? )
|
2005-12-25 21:05:31 -05:00
|
|
|
class-and class-empty? not ;
|
2005-08-16 15:53:30 -04:00
|
|
|
|
2005-08-15 03:25:39 -04:00
|
|
|
: min-class ( class seq -- class/f )
|
|
|
|
#! Is this class the smallest class in the sequence?
|
2005-12-25 21:05:31 -05:00
|
|
|
#! The input sequence should be sorted.
|
|
|
|
[ dupd classes-intersect? ] subset dup empty? [
|
|
|
|
2drop f
|
|
|
|
] [
|
|
|
|
tuck [ class< ] all-with? [ peek ] [ drop f ] if
|
|
|
|
] if ;
|
2005-08-15 03:25:39 -04:00
|
|
|
|
2005-09-16 02:39:33 -04:00
|
|
|
: define-class ( class -- )
|
|
|
|
dup t "class" set-word-prop
|
|
|
|
dup flatten typemap get set-hash ;
|
2005-08-31 21:06:13 -04:00
|
|
|
|
|
|
|
: implementors ( class -- list )
|
|
|
|
#! Find a list of generics that implement a method
|
|
|
|
#! specializing on this class.
|
2005-11-27 17:45:48 -05:00
|
|
|
[ "methods" word-prop ?hash* nip ] word-subset-with ;
|
2005-08-31 21:06:13 -04:00
|
|
|
|
|
|
|
: classes ( -- list )
|
|
|
|
#! Output a list of all defined classes.
|
2005-09-16 02:39:33 -04:00
|
|
|
[ 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
|
2005-09-16 02:39:33 -04:00
|
|
|
define-predicate ;
|
|
|
|
|
|
|
|
PREDICATE: word predicate "definition" word-prop ;
|
|
|
|
|
|
|
|
! Union classes for dispatch on multiple classes.
|
|
|
|
: union-predicate ( members -- list )
|
|
|
|
[
|
2005-11-27 17:45:48 -05:00
|
|
|
"predicate" word-prop \ dup swons [ drop t ] 2array
|
2005-09-16 02:39:33 -04:00
|
|
|
] map [ drop f ] swap alist>quot ;
|
|
|
|
|
|
|
|
: set-members ( class members -- )
|
2005-11-24 19:02:20 -05:00
|
|
|
[ bootstrap-word ] map "members" set-word-prop ;
|
2005-09-16 02:39:33 -04:00
|
|
|
|
|
|
|
: define-union ( class predicate members -- )
|
|
|
|
3dup nip set-members pick define-class
|
|
|
|
union-predicate define-predicate ;
|
|
|
|
|
|
|
|
PREDICATE: word union members ;
|