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