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 words
4 sequences parser namespaces make assocs quotations arrays locals
5 generic generic.math hashtables effects compiler.units ;
6 IN: math.partial-dispatch
10 ! This code will be overhauled and generalized when
11 ! multi-methods go into the core.
12 PREDICATE: math-partial < word
13 "derived-from" word-prop >boolean ;
15 :: fixnum-integer-op ( a b fix-word big-word -- c )
19 a fixnum>bignum b big-word execute
22 :: integer-fixnum-op ( a b fix-word big-word -- c )
26 a b fixnum>bignum big-word execute
29 :: integer-integer-op ( a b fix-word big-word -- c )
31 a b fix-word big-word integer-fixnum-op
33 a dup tag 0 eq? [ fixnum>bignum ] when
37 : integer-op-combinator ( triple -- word )
39 [ second name>> % "-" % ]
40 [ third name>> % "-op" % ]
42 ] "" make "math.partial-dispatch" lookup ;
44 : integer-op-word ( triple -- word )
45 [ name>> ] map "-" join "math.partial-dispatch" create ;
47 : integer-op-quot ( triple fix-word big-word -- quot )
48 rot integer-op-combinator 1quotation 2curry ;
50 : define-integer-op-word ( triple fix-word big-word -- )
52 [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
53 (( x y -- z )) define-declared
56 [ integer-op-word ] keep
57 "derived-from" set-word-prop
60 : define-integer-op-words ( triples fix-word big-word -- )
61 [ define-integer-op-word ] 2curry each ;
63 : integer-op-triples ( word -- triples )
68 } swap [ prefix ] curry map ;
70 : define-integer-ops ( word fix-word big-word -- )
71 >r >r integer-op-triples r> r>
72 [ define-integer-op-words ]
73 [ 2drop [ dup integer-op-word ] { } map>assoc % ]
76 : define-math-ops ( op -- )
77 { fixnum bignum float }
78 [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
80 [ def>> peek ] assoc-map % ;
86 : math-op ( word left right -- word' ? )
87 3array math-ops get at* ;
89 : math-method* ( word left right -- quot )
91 [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
93 : math-both-known? ( word left right -- ? )
96 [ drop math-class-max swap specific-method >boolean ] if ;
98 : (derived-ops) ( word assoc -- words )
99 swap [ rot first eq? nip ] curry assoc-filter values ;
101 : derived-ops ( word -- words )
103 [ math-ops get (derived-ops) ]
106 : fast-derived-ops ( word -- words )
107 fast-math-ops get (derived-ops) ;
109 : all-derived-ops ( word -- words )
110 [ derived-ops ] [ fast-derived-ops ] bi append ;
112 : each-derived-op ( word quot -- )
113 >r derived-ops r> each ; inline
115 : each-fast-derived-op ( word quot -- )
116 >r fast-derived-ops r> each ; inline
123 \ shift define-math-ops
124 \ mod define-math-ops
127 \ bitand define-math-ops
128 \ bitor define-math-ops
129 \ bitxor define-math-ops
135 \ number= define-math-ops
137 \ + \ fixnum+ \ bignum+ define-integer-ops
138 \ - \ fixnum- \ bignum- define-integer-ops
139 \ * \ fixnum* \ bignum* define-integer-ops
140 \ shift \ fixnum-shift \ bignum-shift define-integer-ops
141 \ mod \ fixnum-mod \ bignum-mod define-integer-ops
142 \ /i \ fixnum/i \ bignum/i define-integer-ops
144 \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
145 \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
146 \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
148 \ < \ fixnum< \ bignum< define-integer-ops
149 \ <= \ fixnum<= \ bignum<= define-integer-ops
150 \ > \ fixnum> \ bignum> define-integer-ops
151 \ >= \ fixnum>= \ bignum>= define-integer-ops
152 \ number= \ eq? \ bignum= define-integer-ops
153 ] { } make >hashtable math-ops set-global
156 { { + fixnum fixnum } fixnum+fast }
157 { { - fixnum fixnum } fixnum-fast }
158 { { * fixnum fixnum } fixnum*fast }
159 { { shift fixnum fixnum } fixnum-shift-fast }
160 } fast-math-ops set-global
161 ] with-compilation-unit