steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

generic.math: some minor cleanup.

master
John Benediktsson 2020-02-13 14:54:46 -08:00
parent bcecb3b088
commit c850d38e6c
1 changed files with 5 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
core/generic/math/math.factor
View File

@ -35,12 +35,8 @@ PRIVATE>
[ [ math-precedence ] bi@ after? ] most ; [ [ math-precedence ] bi@ after? ] most ;
: math-upgrade ( class1 class2 -- quot ) : math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep [ math-class-max ] 2keep [ (math-upgrade) ] bi-curry@ bi
[ [ dup empty? [ [ dip ] curry ] unless ] dip [ ] append-as ;
(math-upgrade)
dup empty? [ [ dip ] curry [ ] like ] unless
] [ (math-upgrade) ]
bi-curry* bi append ;
ERROR: no-math-method left right generic ; ERROR: no-math-method left right generic ;
@ -74,8 +70,7 @@ PRIVATE>
SYMBOL: generic-word SYMBOL: generic-word
: make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist ) : make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist )
[ bootstrap-words ] dip [ bootstrap-words ] dip [ keep swap ] curry { } map>assoc ; inline
[ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
: math-alist>quot ( alist -- quot ) : math-alist>quot ( alist -- quot )
[ generic-word get object-method ] dip alist>quot ; [ generic-word get object-method ] dip alist>quot ;
@ -93,8 +88,8 @@ SYMBOL: generic-word
swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
: math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot ) : math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot )
[ [ { bignum float fixnum } ] dip make-math-method-table ] [ { bignum float fixnum } swap make-math-method-table ]
[ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi [ { ratio complex } swap make-math-method-table tuple-dispatch ] 2bi
tuple swap 2array prefix tag-dispatch ; inline tuple swap 2array prefix tag-dispatch ; inline
: fixnum-optimization ( word quot -- word quot' ) : fixnum-optimization ( word quot -- word quot' )