1 ! Copyright (C) 2008 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes.algebra combinators
4 compiler.units fry generic generic.math hashtables kernel make
5 math math.private namespaces quotations sequences words ;
6 IN: math.partial-dispatch
8 PREDICATE: math-partial < word
9 "derived-from" word-prop >boolean ;
11 GENERIC: integer-op-input-classes ( word -- classes )
13 M: math-partial integer-op-input-classes
14 "derived-from" word-prop rest ;
16 ERROR: bad-integer-op word ;
18 M: word integer-op-input-classes
19 dup "input-classes" word-prop
20 [ ] [ bad-integer-op ] ?if-old ;
22 : generic-variant ( op -- generic-op/f )
23 dup "derived-from" word-prop [ first ] [ ] ?if-old ;
25 : no-overflow-variant ( op -- fast-op )
27 { fixnum+ fixnum+fast }
28 { fixnum- fixnum-fast }
29 { fixnum* fixnum*fast }
30 { fixnum-shift fixnum-shift-fast }
31 { fixnum/i fixnum/i-fast }
32 { fixnum/mod fixnum/mod-fast }
35 : modular-variant ( op -- fast-op )
36 generic-variant dup H{
40 { shift fixnum-shift-fast }
41 { bitand fixnum-bitand }
42 { bitor fixnum-bitor }
43 { bitxor fixnum-bitxor }
44 { bitnot fixnum-bitnot }
47 : bignum-fixnum-op-quot ( big-word -- quot )
48 '[ fixnum>bignum _ execute ] ;
50 : fixnum-bignum-op-quot ( big-word -- quot )
51 '[ [ fixnum>bignum ] dip _ execute ] ;
53 : integer-fixnum-op-quot ( fix-word big-word -- quot )
54 bignum-fixnum-op-quot '[ over fixnum? [ _ execute ] _ if ] ;
56 : fixnum-integer-op-quot ( fix-word big-word -- quot )
57 fixnum-bignum-op-quot '[ dup fixnum? [ _ execute ] _ if ] ;
59 : integer-bignum-op-quot ( big-word -- quot )
60 [ fixnum-bignum-op-quot ] keep
61 '[ over fixnum? _ [ _ execute ] if ] ;
63 : integer-integer-op-quot ( fix-word big-word -- quot )
64 [ bignum-fixnum-op-quot ] [ integer-bignum-op-quot ] bi
67 [ _ execute ] [ dup fixnum? _ _ if ] if
70 : integer-op-word ( triple -- word )
71 [ name>> ] map "-" join "math.partial-dispatch" create-word ;
73 : integer-op-quot ( fix-word big-word triple -- quot )
74 [ second ] [ third ] bi 2array {
75 { { fixnum integer } [ fixnum-integer-op-quot ] }
76 { { integer fixnum } [ integer-fixnum-op-quot ] }
77 { { integer integer } [ integer-integer-op-quot ] }
80 : define-integer-op-word ( fix-word big-word triple -- )
82 [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
83 ( x y -- z ) define-declared
86 [ integer-op-word ] keep
87 "derived-from" set-word-prop
90 : define-integer-op-words ( triples fix-word big-word -- )
91 '[ [ _ _ ] dip define-integer-op-word ] each ;
93 : integer-op-triples ( word -- triples )
98 } swap '[ _ prefix ] map ;
100 : define-integer-ops ( word fix-word big-word -- )
103 [ fixnum fixnum 3array "derived-from" set-word-prop ]
104 [ bignum bignum 3array "derived-from" set-word-prop ]
107 [ integer-op-triples ] 2dip
108 [ define-integer-op-words ]
109 [ 2drop [ dup integer-op-word ] { } map>assoc % ]
113 : define-math-ops ( op -- )
114 { fixnum bignum float }
115 [ [ dup 3array ] [ swap ?lookup-method ] 2bi ] with { } map>assoc
118 [ nip length 1 = ] assoc-filter
119 [ first ] assoc-map % ;
123 SYMBOL: fast-math-ops
125 : math-op ( word left right -- word' ? )
126 3array math-ops get at* ;
128 : math-method* ( word left right -- quot )
130 [ 3nip 1quotation ] [ drop math-method ] if ;
132 : math-both-known? ( word left right -- ? )
135 [ drop math-class-max swap method-for-class >boolean ] if ;
137 : (derived-ops) ( word assoc -- words )
138 swap '[ swap first _ eq? nip ] assoc-filter ;
140 : derived-ops ( word -- words )
141 [ 1array ] [ math-ops get (derived-ops) values ] bi append ;
143 : fast-derived-ops ( word -- words )
144 fast-math-ops get (derived-ops) values ;
146 : all-derived-ops ( word -- words )
147 [ derived-ops ] [ fast-derived-ops ] bi append ;
149 : integer-derived-ops ( word -- words )
150 [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
154 [ second integer class<= ]
155 [ third integer class<= ]
157 ] assoc-filter values
160 : each-derived-op ( word quot -- )
161 [ derived-ops ] dip each ; inline
163 : each-fast-derived-op ( word quot -- )
164 [ fast-derived-ops ] dip each ; inline
166 : each-integer-derived-op ( word quot -- )
167 [ integer-derived-ops ] dip each ; inline
174 \ mod define-math-ops
177 \ bitand define-math-ops
178 \ bitor define-math-ops
179 \ bitxor define-math-ops
187 \ u<= define-math-ops
189 \ u>= define-math-ops
191 \ number= define-math-ops
193 { { shift bignum bignum } bignum-shift } ,
194 { { shift fixnum fixnum } fixnum-shift } ,
196 \ + \ fixnum+ \ bignum+ define-integer-ops
197 \ - \ fixnum- \ bignum- define-integer-ops
198 \ * \ fixnum* \ bignum* define-integer-ops
199 \ shift \ fixnum-shift \ bignum-shift define-integer-ops
200 \ mod \ fixnum-mod \ bignum-mod define-integer-ops
201 \ /i \ fixnum/i \ bignum/i define-integer-ops
203 \ simple-gcd \ fixnum-gcd \ bignum-gcd define-integer-ops
205 \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
206 \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
207 \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
209 \ < \ fixnum< \ bignum< define-integer-ops
210 \ <= \ fixnum<= \ bignum<= define-integer-ops
211 \ > \ fixnum> \ bignum> define-integer-ops
212 \ >= \ fixnum>= \ bignum>= define-integer-ops
213 \ number= \ eq? \ bignum= define-integer-ops
214 ] { } make >hashtable math-ops set-global
217 { { + fixnum fixnum } fixnum+fast }
218 { { - fixnum fixnum } fixnum-fast }
219 { { * fixnum fixnum } fixnum*fast }
220 { { shift fixnum fixnum } fixnum-shift-fast }
221 } fast-math-ops set-global
222 ] with-compilation-unit