1 ! Copyright (c) 2008 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel classes.tuple.private hashtables assocs sorting
4 accessors combinators sequences slots.private math.parser words
5 effects namespaces make generic generic.standard.engines
6 classes.algebra math math.private kernel.private
7 quotations arrays definitions ;
8 IN: generic.standard.engines.tuple
10 TUPLE: echelon-dispatch-engine n methods ;
12 C: <echelon-dispatch-engine> echelon-dispatch-engine
14 TUPLE: trivial-tuple-dispatch-engine methods ;
16 C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
18 TUPLE: tuple-dispatch-engine echelons ;
20 : push-echelon ( class method assoc -- )
21 >r swap dup "layout" word-prop echelon>> r>
22 [ ?set-at ] change-at ;
24 : echelon-sort ( assoc -- assoc' )
31 : <tuple-dispatch-engine> ( methods -- engine )
33 [ dupd <echelon-dispatch-engine> ] assoc-map
34 \ tuple-dispatch-engine boa ;
36 : convert-tuple-methods ( assoc -- assoc' )
38 \ <tuple-dispatch-engine> convert-methods ;
40 M: trivial-tuple-dispatch-engine engine>quot
41 methods>> engines>quots* linear-dispatch-quot ;
43 : hash-methods ( methods -- buckets )
44 >alist V{ } clone [ hashcode 1array ] distribute-buckets
45 [ <trivial-tuple-dispatch-engine> ] map ;
47 : word-hashcode% ( -- ) [ 1 slot ] % ;
49 : class-hash-dispatch-quot ( methods -- quot )
53 hash-methods [ engine>quot ] map hash-dispatch-quot %
56 : engine-word-name ( -- string )
57 generic get name>> "/tuple-dispatch-engine" append ;
59 PREDICATE: engine-word < word
60 "tuple-dispatch-generic" word-prop generic? ;
62 M: engine-word stack-effect
63 "tuple-dispatch-generic" word-prop
64 [ extra-values ] [ stack-effect ] bi
65 dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
67 M: engine-word inline?
68 "tuple-dispatch-generic" word-prop inline? ;
70 M: engine-word crossref? "forgotten" word-prop not ;
72 M: engine-word irrelevant? drop t ;
74 : remember-engine ( word -- )
75 generic get "engines" word-prop push ;
77 : <engine-word> ( -- word )
78 engine-word-name f <word>
79 dup generic get "tuple-dispatch-generic" set-word-prop ;
81 : define-engine-word ( quot -- word )
82 >r <engine-word> dup r> define ;
84 : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
86 : tuple-layout-superclasses% ( -- )
89 1 slot { tuple-layout } declare
90 4 slot { array } declare
93 : tuple-dispatch-engine-body ( engine -- quot )
96 tuple-layout-superclasses%
100 <trivial-tuple-dispatch-engine> engine>quot
102 class-hash-dispatch-quot
107 M: echelon-dispatch-engine engine>quot
109 methods>> dup assoc-empty?
110 [ drop default get ] [ values first engine>quot ] if
114 tuple-layout-superclasses%
118 <trivial-tuple-dispatch-engine> engine>quot
120 class-hash-dispatch-quot
126 : >=-case-quot ( alist -- quot )
127 default get [ drop ] prepend swap
129 [ [ dup ] swap [ fixnum>= ] curry compose ]
135 : tuple-layout-echelon% ( -- )
138 1 slot { tuple-layout } declare
142 M: tuple-dispatch-engine engine>quot
145 tuple-layout-echelon%
148 echelons>> dup empty? [
152 engine>quot define-engine-word
153 [ remember-engine ] [ 1quotation ] bi
157 [ first2 engine>quot 2array ] bi*