1 ! Copyright (C) 2006, 2010 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays sequences sequences.private math.private
4 kernel kernel.private math assocs quotations vectors
5 hashtables sorting words sets math.order make ;
8 ! Most of these combinators have compile-time expansions in
9 ! the optimizing compiler. See stack-checker.transforms and
10 ! compiler.tree.propagation.call-effect
14 : call-effect-unsafe ( quot effect -- ) drop call ;
16 : execute-effect-unsafe ( word effect -- ) drop execute ;
19 5 special-object [ die ] or
20 (( error -- * )) call-effect-unsafe ;
24 ERROR: wrong-values quot call-site ;
26 ! We can't USE: effects here so we forward reference slots instead
30 : call-effect ( quot effect -- )
31 ! Don't use fancy combinators here, since this word always
36 dup in>> length swap out>> length
39 [ 2drop ] [ wrong-values ] if ;
41 : execute-effect ( word effect -- )
42 [ [ execute ] curry ] dip call-effect ;
48 : cleave>quot ( seq -- quot )
49 [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
52 : 2cleave ( x y seq -- )
53 [ 2keep ] each 2drop ;
55 : 2cleave>quot ( seq -- quot )
56 [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
59 : 3cleave ( x y z seq -- )
60 [ 3keep ] each 3drop ;
62 : 3cleave>quot ( seq -- quot )
63 [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
66 : spread>quot ( seq -- quot )
67 [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
69 : spread ( objs... seq -- )
76 [ dup callable? [ drop t ] [ first call ] if ] find nip
77 [ dup callable? [ call ] [ second call ] if ]
80 : alist>quot ( default assoc -- quot )
81 [ rot \ if 3array append [ ] like ] assoc-each ;
83 : cond>quot ( assoc -- quot )
84 [ dup pair? [ [ t ] swap 2array ] unless ] map
85 reverse [ no-cond ] swap alist>quot ;
88 ERROR: no-case object ;
90 : case-find ( obj assoc -- obj' )
93 dupd first dup word? [
96 dup wrapper? [ wrapped>> ] when
101 \ case-find t "no-compile" set-word-prop
103 : case ( obj assoc -- )
105 { [ dup array? ] [ nip second call ] }
106 { [ dup callable? ] [ call ] }
107 { [ dup not ] [ drop no-case ] }
110 : linear-case-quot ( default assoc -- quot )
112 [ 1quotation \ dup prefix \ = suffix ]
113 [ \ drop prefix ] bi*
114 ] assoc-map alist>quot ;
118 : (distribute-buckets) ( buckets pair keys -- )
120 drop [ swap adjoin ] curry each
123 [ 2dup ] dip hashcode pick length rem rot nth adjoin
127 : <buckets> ( initial length -- array )
128 next-power-of-2 iota swap [ nip clone ] curry map ;
130 : distribute-buckets ( alist initial quot -- buckets )
131 swapd [ [ dup first ] dip call 2array ] curry map
132 [ length <buckets> dup ] keep
133 [ first2 (distribute-buckets) ] with each ; inline
135 : hash-case-table ( default assoc -- array )
136 V{ } [ 1array ] distribute-buckets
137 [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
139 : hash-dispatch-quot ( table -- quot )
140 [ length 1 - [ fixnum-bitand ] curry ] keep
141 [ dispatch ] curry append ;
143 : hash-case-quot ( default assoc -- quot )
144 hash-case-table hash-dispatch-quot
145 [ dup hashcode >fixnum ] prepend ;
147 : contiguous-range? ( keys -- ? )
148 dup [ fixnum? ] all? [
151 [ [ supremum ] [ infimum ] bi - ]
156 : dispatch-case-quot ( default assoc -- quot )
159 dup keys [ infimum , ] [ supremum , ] bi \ between? ,
161 dup keys infimum , [ - >fixnum ] %
162 sort-keys values [ >quotation ] map ,
164 ] [ ] make , , \ if ,
169 : case>quot ( default assoc -- quot )
171 { [ dup empty? ] [ 2drop ] }
172 { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
173 { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
174 { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] }
175 { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] }
176 [ drop linear-case-quot ]
179 : recursive-hashcode ( n obj quot -- code )
180 pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
182 ! These go here, not in sequences and hashtables, since those
183 ! two cannot depend on us
184 M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
186 M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
188 M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
190 M: hashtable hashcode*
193 [ assoc-hashcode ] [ nip assoc-size ] if
194 ] recursive-hashcode ;
196 : to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) )
197 [ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive