1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs classes classes.algebra combinators
4 definitions generic kernel kernel.private math math.order
5 math.private namespaces quotations sequences words ;
8 PREDICATE: math-class < class
9 dup null bootstrap-word eq? [
12 number bootstrap-word class<=
17 : bootstrap-words ( classes -- classes' )
18 [ bootstrap-word ] map ;
20 : math-precedence ( class -- pair )
22 { fixnum integer rational real number object } bootstrap-words
23 swap [ swap class<= ] curry find drop -1 or
25 { fixnum bignum ratio float complex object } bootstrap-words
26 swap [ class<= ] curry find drop -1 or
29 : (math-upgrade) ( max class -- quot )
30 dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
34 : math-class-max ( class1 class2 -- class )
35 [ [ math-precedence ] bi@ after? ] most ;
37 : math-upgrade ( class1 class2 -- quot )
38 [ math-class-max ] 2keep [ (math-upgrade) ] bi-curry@ bi
39 [ dup empty? [ [ dip ] curry ] unless ] dip [ ] append-as ;
41 ERROR: no-math-method left right generic ;
43 : default-math-method ( generic -- quot )
44 [ no-math-method ] curry [ ] like ;
48 : (math-method) ( generic class -- quot )
51 [ default-math-method ] ?if-old ;
55 : object-method ( generic -- quot )
56 object bootstrap-word (math-method) ;
58 : math-method ( word class1 class2 -- quot )
60 [ 2array [ declare ] curry nip ]
62 [ math-class-max over nearest-class (math-method) ]
72 : make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist )
73 [ bootstrap-words ] dip [ keep swap ] curry { } map>assoc ; inline
75 : math-alist>quot ( alist -- quot )
76 [ generic-word get object-method ] dip alist>quot ;
78 : tag-dispatch-entry ( tag picker -- quot )
79 [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ;
81 : tag-dispatch ( picker alist -- alist' )
82 swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
84 : tuple-dispatch-entry ( class picker -- quot )
85 [ 1quotation [ { tuple } declare class-of ] [ eq? ] surround ] dip prepend ;
87 : tuple-dispatch ( picker alist -- alist' )
88 swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
90 : math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot )
91 [ { bignum float fixnum } swap make-math-method-table ]
92 [ { ratio complex } swap make-math-method-table tuple-dispatch ] 2bi
93 tuple swap 2array prefix tag-dispatch ; inline
95 : fixnum-optimization ( word quot -- word quot' )
96 [ dup fixnum bootstrap-word dup math-method ]
98 ! remove redundant fixnum check since we know
99 ! both can't be fixnums in this branch
100 dup length 3 - cut unclip
101 [ length 2 - ] [ nth ] bi prefix append
103 [ if ] 2curry [ 2dup both-fixnums? ] prepend ;
107 SINGLETON: math-combination
109 M: math-combination make-default-method
110 drop default-math-method ;
112 M: math-combination perform-combination
113 drop dup generic-word [
116 [ dup ] [ math-method ] 2with math-dispatch-step
120 ] with math-dispatch-step
125 PREDICATE: math-generic < generic
126 "combination" word-prop math-combination? ;
128 M: math-generic definer drop \ MATH: f ;