1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs kernel kernel.private slots.private math
4 namespaces make sequences vectors words quotations definitions
5 hashtables layouts combinators sequences.private generic
6 classes classes.algebra classes.private generic.standard.engines
7 generic.standard.engines.tag generic.standard.engines.predicate
8 generic.standard.engines.tuple accessors ;
11 GENERIC: dispatch# ( word -- n )
14 "combination" word-prop dispatch# ;
16 GENERIC: method-declaration ( class generic -- quot )
18 M: generic method-declaration
19 "combination" word-prop method-declaration ;
21 M: quotation engine>quot
22 assumed get generic get method-declaration prepend ;
24 ERROR: no-method object generic ;
26 : error-method ( word -- quot )
27 picker swap [ no-method ] curry append ;
29 : push-method ( method specializer atomic assoc -- )
31 [ H{ } clone <predicate-dispatch-engine> ] unless*
32 [ methods>> set-at ] keep
35 : flatten-method ( class method assoc -- )
36 >r >r dup flatten-class keys swap r> r> [
37 >r spin r> push-method
40 : flatten-methods ( assoc -- assoc' )
47 : <big-dispatch-engine> ( assoc -- engine )
50 convert-hi-tag-methods
51 <lo-tag-dispatch-engine> ;
53 : find-default ( methods -- quot )
54 #! Side-effects methods.
55 object bootstrap-word swap delete-at* [
56 drop generic get "default-method" word-prop 1quotation
59 : mangle-method ( method generic -- quot )
60 [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
63 : single-combination ( word -- quot )
65 object bootstrap-word assumed set {
67 [ "engines" word-prop forget-all ]
68 [ V{ } clone "engines" set-word-prop ]
71 [ generic get mangle-method ] assoc-map
72 [ find-default default set ]
73 [ <big-dispatch-engine> ]
79 ERROR: inconsistent-next-method class generic ;
81 ERROR: no-next-method class generic ;
83 : single-next-method-quot ( class generic -- quot )
85 [ drop "predicate" word-prop % ]
89 [ [ no-next-method ] 2curry [ ] like ] if* ,
91 [ [ inconsistent-next-method ] 2curry , ]
96 : single-effective-method ( obj word -- method )
97 [ [ order [ instance? ] with find-last nip ] keep method ]
98 [ "default-method" word-prop ]
101 TUPLE: standard-combination # ;
103 C: <standard-combination> standard-combination
105 PREDICATE: standard-generic < generic
106 "combination" word-prop standard-combination? ;
108 PREDICATE: simple-generic < standard-generic
109 "combination" word-prop #>> zero? ;
111 : define-simple-generic ( word -- )
112 T{ standard-combination f 0 } define-generic ;
114 : with-standard ( combination quot -- quot' )
115 >r #>> (dispatch#) r> with-variable ; inline
117 M: standard-generic extra-values drop 0 ;
119 M: standard-combination make-default-method
120 [ error-method ] with-standard ;
122 M: standard-combination perform-combination
123 [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
125 M: standard-combination dispatch# #>> ;
127 M: standard-combination method-declaration
128 dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
130 M: standard-combination next-method-quot*
132 single-next-method-quot picker prepend
135 M: standard-generic effective-method
136 [ dispatch# (picker) call ] keep single-effective-method ;
138 TUPLE: hook-combination var ;
140 C: <hook-combination> hook-combination
142 PREDICATE: hook-generic < generic
143 "combination" word-prop hook-combination? ;
145 : with-hook ( combination quot -- quot' )
147 dip var>> [ get ] curry prepend
148 ] with-variable ; inline
150 M: hook-combination dispatch# drop 0 ;
152 M: hook-combination method-declaration 2drop [ ] ;
154 M: hook-generic extra-values drop 1 ;
156 M: hook-generic effective-method
157 [ "combination" word-prop var>> get ] keep
158 single-effective-method ;
160 M: hook-combination make-default-method
161 [ error-method ] with-hook ;
163 M: hook-combination perform-combination
164 [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
166 M: hook-combination next-method-quot*
167 [ single-next-method-quot ] with-hook ;
169 M: simple-generic definer drop \ GENERIC: f ;
171 M: standard-generic definer drop \ GENERIC# f ;
173 M: hook-generic definer drop \ HOOK: f ;