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 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 )
13 M: word dispatch# "combination" word-prop dispatch# ;
19 [ >r >r nip r> r> -rot ]
22 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
24 ERROR: no-method object generic ;
26 : error-method ( word -- quot )
27 picker swap [ no-method ] curry append ;
29 : empty-method ( word -- quot )
31 picker % [ delegate dup ] %
32 unpicker over suffix ,
33 error-method \ drop prefix , \ if ,
36 : default-method ( word -- pair )
37 "default-method" word-prop
38 object bootstrap-word swap 2array ;
40 : push-method ( method specializer atomic assoc -- )
42 [ H{ } clone <predicate-dispatch-engine> ] unless*
43 [ methods>> set-at ] keep
46 : flatten-method ( class method assoc -- )
47 >r >r dup flatten-class keys swap r> r> [
48 >r spin r> push-method
51 : flatten-methods ( assoc -- assoc' )
58 : <big-dispatch-engine> ( assoc -- engine )
61 convert-hi-tag-methods
62 <lo-tag-dispatch-engine> ;
64 : find-default ( methods -- quot )
65 #! Side-effects methods.
66 object bootstrap-word swap delete-at* [
67 drop generic get "default-method" word-prop 1quotation
70 : mangle-method ( method generic -- quot )
71 [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
74 : single-combination ( word -- quot )
76 object bootstrap-word assumed set {
78 [ "engines" word-prop forget-all ]
79 [ V{ } clone "engines" set-word-prop ]
82 [ generic get mangle-method ] assoc-map
83 [ find-default default set ]
84 [ <big-dispatch-engine> ]
90 ERROR: inconsistent-next-method class generic ;
92 ERROR: no-next-method class generic ;
94 : single-next-method-quot ( class generic -- quot )
96 [ drop "predicate" word-prop % ]
100 [ [ no-next-method ] 2curry [ ] like ] if* ,
102 [ [ inconsistent-next-method ] 2curry , ]
107 : single-effective-method ( obj word -- method )
108 [ order [ instance? ] with find-last nip ] keep method ;
110 TUPLE: standard-combination # ;
112 C: <standard-combination> standard-combination
114 PREDICATE: standard-generic < generic
115 "combination" word-prop standard-combination? ;
117 PREDICATE: simple-generic < standard-generic
118 "combination" word-prop #>> zero? ;
120 : define-simple-generic ( word -- )
121 T{ standard-combination f 0 } define-generic ;
123 : with-standard ( combination quot -- quot' )
124 >r #>> (dispatch#) r> with-variable ; inline
126 M: standard-generic extra-values drop 0 ;
128 M: standard-combination make-default-method
129 [ empty-method ] with-standard ;
131 M: standard-combination perform-combination
132 [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
134 M: standard-combination dispatch# #>> ;
136 M: standard-combination next-method-quot*
138 single-next-method-quot picker prepend
141 M: standard-generic effective-method
142 [ dispatch# (picker) call ] keep single-effective-method ;
144 TUPLE: hook-combination var ;
146 C: <hook-combination> hook-combination
148 PREDICATE: hook-generic < generic
149 "combination" word-prop hook-combination? ;
151 : with-hook ( combination quot -- quot' )
153 dip var>> [ get ] curry prepend
154 ] with-variable ; inline
156 M: hook-combination dispatch# drop 0 ;
158 M: hook-generic extra-values drop 1 ;
160 M: hook-generic effective-method
161 [ "combination" word-prop var>> get ] keep
162 single-effective-method ;
164 M: hook-combination make-default-method
165 [ error-method ] with-hook ;
167 M: hook-combination perform-combination
168 [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
170 M: hook-combination next-method-quot*
171 [ single-next-method-quot ] with-hook ;
173 M: simple-generic definer drop \ GENERIC: f ;
175 M: standard-generic definer drop \ GENERIC# f ;
177 M: hook-generic definer drop \ HOOK: f ;