1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel kernel.private math math.private
4 math.functions math.functions.private sequences parser
5 namespaces make assocs quotations arrays generic generic.math
6 hashtables effects compiler.units classes.algebra fry
8 IN: math.partial-dispatch
10 PREDICATE: math-partial < word
11 "derived-from" word-prop >boolean ;
13 GENERIC: integer-op-input-classes ( word -- classes )
15 M: math-partial integer-op-input-classes
16 "derived-from" word-prop rest ;
18 ERROR: bad-integer-op word ;
20 M: word integer-op-input-classes
21 dup "input-classes" word-prop
22 [ ] [ bad-integer-op ] ?if ;
24 : generic-variant ( op -- generic-op/f )
25 dup "derived-from" word-prop [ first ] [ ] ?if ;
27 : no-overflow-variant ( op -- fast-op )
29 { fixnum+ fixnum+fast }
30 { fixnum- fixnum-fast }
31 { fixnum* fixnum*fast }
32 { fixnum-shift fixnum-shift-fast }
33 { fixnum/i fixnum/i-fast }
34 { fixnum/mod fixnum/mod-fast }
37 : modular-variant ( op -- fast-op )
38 generic-variant dup H{
42 { shift fixnum-shift-fast }
43 { bitand fixnum-bitand }
44 { bitor fixnum-bitor }
45 { bitxor fixnum-bitxor }
46 { bitnot fixnum-bitnot }
49 : bignum-fixnum-op-quot ( big-word -- quot )
50 '[ fixnum>bignum _ execute ] ;
52 : fixnum-bignum-op-quot ( big-word -- quot )
53 '[ [ fixnum>bignum ] dip _ execute ] ;
55 : integer-fixnum-op-quot ( fix-word big-word -- quot )
58 [ '[ _ execute ] , ] [ bignum-fixnum-op-quot , ] bi* \ if ,
61 : fixnum-integer-op-quot ( fix-word big-word -- quot )
64 [ '[ _ execute ] , ] [ fixnum-bignum-op-quot , ] bi* \ if ,
67 : integer-bignum-op-quot ( big-word -- quot )
70 [ fixnum-bignum-op-quot , ] [ '[ _ execute ] , ] bi \ if ,
73 : integer-integer-op-quot ( fix-word big-word -- quot )
75 [ 2dup both-fixnums? ] %
80 [ bignum-fixnum-op-quot , ]
81 [ integer-bignum-op-quot , ] bi \ if ,
86 : integer-op-word ( triple -- word )
87 [ name>> ] map "-" join "math.partial-dispatch" create ;
89 : integer-op-quot ( fix-word big-word triple -- quot )
90 [ second ] [ third ] bi 2array {
91 { { fixnum integer } [ fixnum-integer-op-quot ] }
92 { { integer fixnum } [ integer-fixnum-op-quot ] }
93 { { integer integer } [ integer-integer-op-quot ] }
96 : define-integer-op-word ( fix-word big-word triple -- )
98 [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
99 ( x y -- z ) define-declared
102 [ integer-op-word ] keep
103 "derived-from" set-word-prop
106 : define-integer-op-words ( triples fix-word big-word -- )
107 '[ [ _ _ ] dip define-integer-op-word ] each ;
109 : integer-op-triples ( word -- triples )
114 } swap '[ _ prefix ] map ;
116 : define-integer-ops ( word fix-word big-word -- )
119 [ fixnum fixnum 3array "derived-from" set-word-prop ]
120 [ bignum bignum 3array "derived-from" set-word-prop ]
123 [ integer-op-triples ] 2dip
124 [ define-integer-op-words ]
125 [ 2drop [ dup integer-op-word ] { } map>assoc % ]
129 : define-math-ops ( op -- )
130 { fixnum bignum float }
131 [ [ dup 3array ] [ swap ?lookup-method ] 2bi ] with { } map>assoc
134 [ nip length 1 = ] assoc-filter
135 [ first ] assoc-map % ;
139 SYMBOL: fast-math-ops
141 : math-op ( word left right -- word' ? )
142 3array math-ops get at* ;
144 : math-method* ( word left right -- quot )
146 [ [ 3drop ] dip 1quotation ] [ drop math-method ] if ;
148 : math-both-known? ( word left right -- ? )
151 [ drop math-class-max swap method-for-class >boolean ] if ;
153 : (derived-ops) ( word assoc -- words )
154 swap '[ swap first _ eq? nip ] assoc-filter ;
156 : derived-ops ( word -- words )
157 [ 1array ] [ math-ops get (derived-ops) values ] bi append ;
159 : fast-derived-ops ( word -- words )
160 fast-math-ops get (derived-ops) values ;
162 : all-derived-ops ( word -- words )
163 [ derived-ops ] [ fast-derived-ops ] bi append ;
165 : integer-derived-ops ( word -- words )
166 [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
170 [ second integer class<= ]
171 [ third integer class<= ]
173 ] assoc-filter values
176 : each-derived-op ( word quot -- )
177 [ derived-ops ] dip each ; inline
179 : each-fast-derived-op ( word quot -- )
180 [ fast-derived-ops ] dip each ; inline
182 : each-integer-derived-op ( word quot -- )
183 [ integer-derived-ops ] dip each ; inline
190 \ mod define-math-ops
193 \ bitand define-math-ops
194 \ bitor define-math-ops
195 \ bitxor define-math-ops
203 \ u<= define-math-ops
205 \ u>= define-math-ops
207 \ number= define-math-ops
209 { { shift bignum bignum } bignum-shift } ,
210 { { shift fixnum fixnum } fixnum-shift } ,
212 \ + \ fixnum+ \ bignum+ define-integer-ops
213 \ - \ fixnum- \ bignum- define-integer-ops
214 \ * \ fixnum* \ bignum* define-integer-ops
215 \ shift \ fixnum-shift \ bignum-shift define-integer-ops
216 \ mod \ fixnum-mod \ bignum-mod define-integer-ops
217 \ /i \ fixnum/i \ bignum/i define-integer-ops
219 \ fast-gcd \ simple-gcd \ bignum-gcd define-integer-ops
221 \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
222 \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
223 \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
225 \ < \ fixnum< \ bignum< define-integer-ops
226 \ <= \ fixnum<= \ bignum<= define-integer-ops
227 \ > \ fixnum> \ bignum> define-integer-ops
228 \ >= \ fixnum>= \ bignum>= define-integer-ops
229 \ number= \ eq? \ bignum= define-integer-ops
230 ] { } make >hashtable math-ops set-global
233 { { + fixnum fixnum } fixnum+fast }
234 { { - fixnum fixnum } fixnum-fast }
235 { { * fixnum fixnum } fixnum*fast }
236 { { shift fixnum fixnum } fixnum-shift-fast }
237 } fast-math-ops set-global
238 ] with-compilation-unit