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

math.partial-dispatch: simplify using fry.

clean-macosx-x86-64
John Benediktsson 2019-10-31 10:27:29 -07:00
parent bccdb5419b
commit 52123559f3
1 changed files with 12 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -1,10 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private USING: accessors arrays assocs classes.algebra combinators
math.functions math.functions.private sequences parser compiler.units fry generic generic.math hashtables kernel make
namespaces make assocs quotations arrays generic generic.math math math.private namespaces quotations sequences words ;
hashtables effects compiler.units classes.algebra fry
combinators words ;
IN: math.partial-dispatch IN: math.partial-dispatch
PREDICATE: math-partial < word PREDICATE: math-partial < word
@ -53,35 +51,21 @@ M: word integer-op-input-classes
'[ [ fixnum>bignum ] dip _ execute ] ; '[ [ fixnum>bignum ] dip _ execute ] ;
: integer-fixnum-op-quot ( fix-word big-word -- quot ) : integer-fixnum-op-quot ( fix-word big-word -- quot )
[ bignum-fixnum-op-quot '[ over fixnum? [ _ execute ] _ if ] ;
[ over fixnum? ] %
[ '[ _ execute ] , ] [ bignum-fixnum-op-quot , ] bi* \ if ,
] [ ] make ;
: fixnum-integer-op-quot ( fix-word big-word -- quot ) : fixnum-integer-op-quot ( fix-word big-word -- quot )
[ fixnum-bignum-op-quot '[ dup fixnum? [ _ execute ] _ if ] ;
[ dup fixnum? ] %
[ '[ _ execute ] , ] [ fixnum-bignum-op-quot , ] bi* \ if ,
] [ ] make ;
: integer-bignum-op-quot ( big-word -- quot ) : integer-bignum-op-quot ( big-word -- quot )
[ [ fixnum-bignum-op-quot ] keep
[ over fixnum? ] % '[ over fixnum? _ [ _ execute ] if ] ;
[ fixnum-bignum-op-quot , ] [ '[ _ execute ] , ] bi \ if ,
] [ ] make ;
: integer-integer-op-quot ( fix-word big-word -- quot ) : integer-integer-op-quot ( fix-word big-word -- quot )
[ [ bignum-fixnum-op-quot ] [ integer-bignum-op-quot ] bi
[ 2dup both-fixnums? ] % '[
[ '[ _ execute ] , ] 2dup both-fixnums?
[ [ _ execute ] [ dup fixnum? _ _ if ] if
[ ] ;
[ dup fixnum? ] %
[ bignum-fixnum-op-quot , ]
[ integer-bignum-op-quot , ] bi \ if ,
] [ ] make ,
] bi* \ if ,
] [ ] make ;
: integer-op-word ( triple -- word ) : integer-op-word ( triple -- word )
[ name>> ] map "-" join "math.partial-dispatch" create-word ; [ name>> ] map "-" join "math.partial-dispatch" create-word ;