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 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 crossref? "forgotten" word-prop not ;
69 M: engine-word irrelevant? drop t ;
71 : remember-engine ( word -- )
72 generic get "engines" word-prop push ;
74 : <engine-word> ( -- word )
75 engine-word-name f <word>
76 dup generic get "tuple-dispatch-generic" set-word-prop ;
78 : define-engine-word ( quot -- word )
79 >r <engine-word> dup r> define ;
81 : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
83 : tuple-layout-superclasses ( obj -- array )
85 1 slot { tuple-layout } declare
86 4 slot { array } declare ; inline
88 : tuple-dispatch-engine-body ( engine -- quot )
91 [ tuple-layout-superclasses ] %
95 <trivial-tuple-dispatch-engine> engine>quot
97 class-hash-dispatch-quot
102 M: echelon-dispatch-engine engine>quot
104 methods>> dup assoc-empty?
105 [ drop default get ] [ values first engine>quot ] if
109 [ tuple-layout-superclasses ] %
113 <trivial-tuple-dispatch-engine> engine>quot
115 class-hash-dispatch-quot
121 : >=-case-quot ( alist -- quot )
122 default get [ drop ] prepend swap
123 [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
126 : tuple-layout-echelon ( obj -- array )
128 1 slot { tuple-layout } declare
131 M: tuple-dispatch-engine engine>quot
134 [ tuple-layout-echelon ] %
137 echelons>> dup empty? [
141 engine>quot define-engine-word
142 [ remember-engine ] [ 1quotation ] bi
146 [ first2 engine>quot 2array ] bi*