String vocab, String word, List completions, boolean anywhere)
{
FactorNamespace v = interp.getVocabulary(vocab);
+ if(v == null)
+ return;
+
Cons words = v.toValueList();
while(words != null)
DEFER: next-io-task
IN: math
-DEFER: number=
+DEFER: arithmetic-type
DEFER: >fraction
DEFER: fraction>
+DEFER: fixnum=
+DEFER: fixnum+
+DEFER: fixnum-
+DEFER: fixnum*
+DEFER: fixnum/i
+DEFER: fixnum/f
+DEFER: fixnum-mod
+DEFER: fixnum/mod
+DEFER: fixnum-bitand
+DEFER: fixnum-bitor
+DEFER: fixnum-bitxor
+DEFER: fixnum-bitnot
+DEFER: fixnum-shift
+DEFER: fixnum<
+DEFER: fixnum<=
+DEFER: fixnum>
+DEFER: fixnum>=
+DEFER: bignum=
+DEFER: bignum+
+DEFER: bignum-
+DEFER: bignum*
+DEFER: bignum/i
+DEFER: bignum/f
+DEFER: bignum-mod
+DEFER: bignum/mod
+DEFER: bignum-bitand
+DEFER: bignum-bitor
+DEFER: bignum-bitxor
+DEFER: bignum-bitnot
+DEFER: bignum-shift
+DEFER: bignum<
+DEFER: bignum<=
+DEFER: bignum>
+DEFER: bignum>=
+DEFER: float=
+DEFER: float+
+DEFER: float-
+DEFER: float*
+DEFER: float/f
+DEFER: float<
+DEFER: float<=
+DEFER: float>
+DEFER: float>=
IN: parser
DEFER: str>float
sbuf-reverse
sbuf-clone
sbuf=
+ arithmetic-type
number?
>fixnum
>bignum
>float
- number=
numerator
denominator
>fraction
imaginary
>rect
rect>
- +
- -
- *
- /i
- /f
- /
- mod
- /mod
- bitand
- bitor
- bitxor
- bitnot
- shift
- <
- <=
- >
- >=
+ fixnum=
+ fixnum+
+ fixnum-
+ fixnum*
+ fixnum/i
+ fixnum/f
+ fixnum-mod
+ fixnum/mod
+ fixnum-bitand
+ fixnum-bitor
+ fixnum-bitxor
+ fixnum-bitnot
+ fixnum-shift
+ fixnum<
+ fixnum<=
+ fixnum>
+ fixnum>=
+ bignum=
+ bignum+
+ bignum-
+ bignum*
+ bignum/i
+ bignum/f
+ bignum-mod
+ bignum/mod
+ bignum-bitand
+ bignum-bitor
+ bignum-bitxor
+ bignum-bitnot
+ bignum-shift
+ bignum<
+ bignum<=
+ bignum>
+ bignum>=
+ float=
+ float+
+ float-
+ float*
+ float/f
+ float<
+ float<=
+ float>
+ float>=
facos
fasin
fatan
"/library/platform/native/kernel.factor"
"/library/platform/native/stack.factor"
"/library/platform/native/types.factor"
+ "/library/platform/native/math.factor"
"/library/cons.factor"
"/library/combinators.factor"
"/library/logic.factor"
uncons car "Maximum index: " write .
"Requested index: " write . ;
-: numerical-comparison-error ( list -- )
- "Cannot compare " write unswons unparse write
- " with " write unparse print ;
-
: float-format-error ( list -- )
"Invalid floating point literal format: " write . ;
undefined-word-error
type-check-error
array-range-error
- numerical-comparison-error
float-format-error
signal-error
profiling-disabled-error
: generic ( obj vtable -- )
over type-of swap vector-nth call ;
+: 2generic ( n n map -- )
+ >r 2dup arithmetic-type r> vector-nth execute ;
+
: hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes.
{
#! Push t if a is isomorphic to b.
2dup eq? [ 2drop t ] [ equal? ] ifte ;
+: 2= ( a b c d -- ? )
+ #! Test if a = c, b = d.
+ swapd = [ = ] [ 2drop f ] ifte ;
+
: clone ( obj -- obj )
[
[ cons? ] [ clone-list ]
IN: math
USE: combinators
+USE: errors
USE: kernel
USE: stack
+USE: vectors
+USE: words
-: (gcd) ( x y -- z )
- dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
+: abs ( z -- abs )
+ #! This definition is replaced when the remainder of the
+ #! math library is read in at stage2.
+ dup 0 < [ neg ] when ;
-: gcd ( x y -- z )
- #! Greatest common divisor.
- abs swap abs 2dup < [ swap ] when (gcd) ;
+: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
+: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
+
+: reduce ( x y -- x' y' )
+ dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
+: ratio ( x y -- x/y ) reduce fraction> ;
+: 2>fraction ( a/b c/d -- a b c d ) >r >fraction r> >fraction ;
+
+: ratio= ( a/b c/d -- ? ) 2>fraction 2= ;
+: ratio-scale ( a/b c/d -- a*d b*c ) 2>fraction -rot * >r * r> ;
+: ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ;
+: ratio+ ( x y -- x+y ) 2dup ratio-scale + -rot ratio+d ratio ;
+: ratio- ( x y -- x-y ) 2dup ratio-scale - -rot ratio+d ratio ;
+: ratio* ( x y -- x*y ) 2>fraction swapd * >r * r> ratio ;
+: ratio/ ( x y -- x/y ) ratio-scale ratio ;
+: ratio/f ( x y -- x/y ) ratio-scale /f ;
+
+: ratio< ( x y -- ? ) ratio-scale < ;
+: ratio<= ( x y -- ? ) ratio-scale <= ;
+: ratio> ( x y -- ? ) ratio-scale > ;
+: ratio>= ( x y -- ? ) ratio-scale >= ;
+
+: 2>rect ( x y -- x:re x:im y:re y:im ) >r >rect r> >rect ;
+
+: complex= ( x y -- ? ) 2>rect 2= ;
+: complex+ ( x y -- x+y ) 2>rect swapd + >r + r> rect> ;
+: complex- ( x y -- x-y ) 2>rect swapd - >r - r> rect> ;
+: complex*re ( x y -- zx:re * y:re x:im * r:im )
+ 2>rect swapd * >r * r> ;
+: complex*im ( x y -- x:re * y:im x:im * y:re )
+ 2>rect >r * swap r> * ;
+: complex* ( x y -- x*y )
+ 2dup complex*re - -rot complex*im + rect> ;
+: abs^2 ( x -- y ) >rect sq swap sq + ;
+: (complex/) ( x y -- r i m )
+ #! r = x:re * y:re + x:im * y:im
+ #! i = x:im * y:re - x:re * y:im
+ #! m = y:re * y:re + y:im * y:im
+ dup abs^2 >r 2dup complex*re + -rot complex*im - r> ;
+: complex/ ( x y -- x/y )
+ (complex/) tuck / >r / r> rect> ;
+: complex/f ( x y -- x/y )
+ (complex/) tuck /f >r /f r> rect> ;
+
+: no-method ( -- )
+ "No applicable method" throw ;
+
+: (not-=) ( x y -- f )
+ 2drop f ;
+
+: number= ( x y -- ? )
+ {
+ fixnum=
+ (not-=)
+ (not-=)
+ (not-=)
+ ratio=
+ complex=
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ (not-=)
+ bignum=
+ float=
+ (not-=)
+ } 2generic ;
+
+: + ( x y -- x+y )
+ {
+ fixnum+
+ no-method
+ no-method
+ no-method
+ ratio+
+ complex+
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum+
+ float+
+ no-method
+ } 2generic ;
+
+: - ( x y -- x-y )
+ {
+ fixnum-
+ no-method
+ no-method
+ no-method
+ ratio-
+ complex-
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-
+ float-
+ no-method
+ } 2generic ;
+
+: * ( x y -- x*y )
+ {
+ fixnum*
+ no-method
+ no-method
+ no-method
+ ratio*
+ complex*
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum*
+ float*
+ no-method
+ } 2generic ;
+
+: / ( x y -- x/y )
+ {
+ ratio
+ no-method
+ no-method
+ no-method
+ ratio/
+ complex/
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ ratio
+ float/f
+ no-method
+ } 2generic ;
+
+: /i ( x y -- x/y )
+ {
+ fixnum/i
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum/i
+ no-method
+ no-method
+ } 2generic ;
+
+: /f ( x y -- x/y )
+ {
+ fixnum/f
+ no-method
+ no-method
+ no-method
+ ratio/f
+ complex/f
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum/f
+ float/f
+ no-method
+ } 2generic ;
+
+: mod ( x y -- x%y )
+ {
+ fixnum-mod
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-mod
+ no-method
+ no-method
+ } 2generic ;
+
+: /mod ( x y -- x/y x%y )
+ {
+ fixnum/mod
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum/mod
+ no-method
+ no-method
+ } 2generic ;
+
+: bitand ( x y -- x&y )
+ {
+ fixnum-bitand
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitand
+ no-method
+ no-method
+ } 2generic ;
+
+: bitor ( x y -- x|y )
+ {
+ fixnum-bitor
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitor
+ no-method
+ no-method
+ } 2generic ;
+
+: bitxor ( x y -- x^y )
+ {
+ fixnum-bitxor
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-bitxor
+ no-method
+ no-method
+ } 2generic ;
+
+: bitnot ( x -- ~x )
+ {
+ [ fixnum-bitnot ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ no-method ]
+ [ bignum-bitnot ]
+ [ no-method ]
+ [ no-method ]
+ } generic ;
+
+: shift ( x n -- x<<n )
+ {
+ fixnum-shift
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum-shift
+ no-method
+ no-method
+ } 2generic ;
+
+: < ( x y -- ? )
+ {
+ fixnum<
+ no-method
+ no-method
+ no-method
+ ratio<
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum<
+ float<
+ no-method
+ } 2generic ;
+
+: <= ( x y -- ? )
+ {
+ fixnum<=
+ no-method
+ no-method
+ no-method
+ ratio<=
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum<=
+ float<=
+ no-method
+ } 2generic ;
+
+: > ( x y -- ? )
+ {
+ fixnum>
+ no-method
+ no-method
+ no-method
+ ratio>
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum>
+ float>
+ no-method
+ } 2generic ;
+
+: >= ( x y -- ? )
+ {
+ fixnum>=
+ no-method
+ no-method
+ no-method
+ ratio>=
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ no-method
+ bignum>=
+ float>=
+ no-method
+ } 2generic ;
[ str-hashcode | " str -- n " ]
[ index-of* | " n str/ch str -- n " ]
[ substring | " start end str -- str "]
+ [ str-reverse | " str -- str " ]
[ <sbuf> | " capacity -- sbuf " ]
[ sbuf-length | " sbuf -- n " ]
[ set-sbuf-length | " n sbuf -- " ]
[ sbuf-reverse | " sbuf -- " ]
[ sbuf-clone | " sbuf -- sbuf " ]
[ sbuf= | " sbuf sbuf -- ? " ]
+ [ arithmetic-type | " n n -- type " ]
[ number? | " obj -- ? " ]
[ >fixnum | " n -- fixnum " ]
[ >bignum | " n -- bignum " ]
[ >float | " n -- float " ]
- [ number= | " n n -- ? " ]
[ numerator | " a/b -- a " ]
[ denominator | " a/b -- b " ]
[ >fraction | " a/b -- a b " ]
[ str>float | " str -- float " ]
[ unparse-float | " float -- str " ]
[ float>bits | " float -- n " ]
- [ complex? | " obj -- ? " ]
[ real | " #{ re im } -- re " ]
[ imaginary | " #{ re im } -- im " ]
[ >rect | " #{ re im } -- re im " ]
[ rect> | " re im -- #{ re im } " ]
- [ + | " x y -- x+y " ]
- [ - | " x y -- x-y " ]
- [ * | " x y -- x*y " ]
- [ /i | " x y -- x/y " ]
- [ /f | " x y -- x/y " ]
- [ / | " x y -- x/y " ]
- [ mod | " x y -- x%y " ]
- [ /mod | " x y -- x/y x%y " ]
- [ bitand | " x y -- x&y " ]
- [ bitor | " x y -- x|y " ]
- [ bitxor | " x y -- x^y " ]
- [ bitnot | " x -- ~x " ]
- [ shift | " x n -- x<<n" ]
- [ < | " x y -- ? " ]
- [ <= | " x y -- ? " ]
- [ > | " x y -- ? " ]
- [ >= | " x y -- ? " ]
+ [ fixnum= | " x y -- ? " ]
+ [ fixnum+ | " x y -- x+y " ]
+ [ fixnum- | " x y -- x-y " ]
+ [ fixnum* | " x y -- x*y " ]
+ [ fixnum/i | " x y -- x/y " ]
+ [ fixnum/f | " x y -- x/y " ]
+ [ fixnum-mod | " x y -- x%y " ]
+ [ fixnum/mod | " x y -- x/y x%y " ]
+ [ fixnum-bitand | " x y -- x&y " ]
+ [ fixnum-bitor | " x y -- x|y " ]
+ [ fixnum-bitxor | " x y -- x^y " ]
+ [ fixnum-bitnot | " x -- ~x " ]
+ [ fixnum-shift | " x n -- x<<n" ]
+ [ fixnum< | " x y -- ? " ]
+ [ fixnum<= | " x y -- ? " ]
+ [ fixnum> | " x y -- ? " ]
+ [ fixnum>= | " x y -- ? " ]
+ [ bignum= | " x y -- ? " ]
+ [ bignum+ | " x y -- x+y " ]
+ [ bignum- | " x y -- x-y " ]
+ [ bignum* | " x y -- x*y " ]
+ [ bignum/i | " x y -- x/y " ]
+ [ bignum/f | " x y -- x/y " ]
+ [ bignum-mod | " x y -- x%y " ]
+ [ bignum/mod | " x y -- x/y x%y " ]
+ [ bignum-bitand | " x y -- x&y " ]
+ [ bignum-bitor | " x y -- x|y " ]
+ [ bignum-bitxor | " x y -- x^y " ]
+ [ bignum-bitnot | " x -- ~x " ]
+ [ bignum-shift | " x n -- x<<n" ]
+ [ bignum< | " x y -- ? " ]
+ [ bignum<= | " x y -- ? " ]
+ [ bignum> | " x y -- ? " ]
+ [ bignum>= | " x y -- ? " ]
+ [ float= | " x y -- ? " ]
+ [ float+ | " x y -- x+y " ]
+ [ float- | " x y -- x-y " ]
+ [ float* | " x y -- x*y " ]
+ [ float/f | " x y -- x/y " ]
+ [ float< | " x y -- ? " ]
+ [ float<= | " x y -- ? " ]
+ [ float> | " x y -- ? " ]
+ [ float>= | " x y -- ? " ]
[ facos | " x -- y " ]
[ fasin | " x -- y " ]
[ fatan | " x -- y " ]
[ fsqrt | " x -- y " ]
[ <word> | " prim param plist -- word " ]
[ word-hashcode | " word -- n " ]
+ [ word-xt | " word -- xt " ]
+ [ set-word-xt | " xt word -- " ]
[ word-primitive | " word -- n " ]
[ set-word-primitive | " n word -- " ]
[ word-parameter | " word -- obj " ]
[ add-write-io-task | " port callback -- " ]
[ write-fd-8 | " ch/str port -- " ]
[ add-copy-io-task | " from to callback -- " ]
+ [ pending-io-error | " -- " ]
[ next-io-task | " -- callback " ]
[ room | " -- free total " ]
[ os-env | " str -- str " ]
[ set-compiled-offset | " ptr -- " ]
[ literal-top | " -- ptr " ]
[ set-literal-top | " ptr -- " ]
+ [ address-of | " obj -- ptr " ]
[ dlopen | " path -- dll " ]
[ dlsym | " name dll -- ptr " ]
[ dlsym-self | " name -- ptr " ]
}
}
+void primitive_arithmetic_type(void)
+{
+ CELL type2 = type_of(dpop());
+ CELL type1 = type_of(dpop());
+ dpush(tag_fixnum(upgraded_arithmetic_type(type1,type2)));
+}
+
bool realp(CELL tagged)
{
switch(type_of(tagged))
switch(type_of(tagged))
{
case FIXNUM_TYPE:
- return tagged == 1;
+ return tagged == tag_fixnum(1);
case BIGNUM_TYPE:
return BIGNUM_ONE_P((ARRAY*)UNTAG(tagged),0);
case FLOAT_TYPE:
return false; /* Can't happen */
}
}
-
-/* EQUALITY */
-CELL number_eq_anytype(CELL x, CELL y)
-{
- return F;
-}
-
-
-BINARY_OP(number_eq)
-
-BINARY_OP_NUMBER_ONLY(add)
-BINARY_OP(add)
-
-BINARY_OP_NUMBER_ONLY(subtract)
-BINARY_OP(subtract)
-
-BINARY_OP_NUMBER_ONLY(multiply)
-BINARY_OP(multiply)
-
-BINARY_OP_NUMBER_ONLY(divide)
-BINARY_OP(divide)
-
-BINARY_OP_INTEGER_ONLY(divint)
-BINARY_OP_NUMBER_ONLY(divint)
-BINARY_OP(divint)
-
-BINARY_OP_NUMBER_ONLY(divfloat)
-BINARY_OP(divfloat)
-
-BINARY_OP_INTEGER_ONLY(divmod)
-BINARY_OP_NUMBER_ONLY(divmod)
-BINARY_OP(divmod)
-
-BINARY_OP_INTEGER_ONLY(mod)
-BINARY_OP_NUMBER_ONLY(mod)
-BINARY_OP(mod)
-
-BINARY_OP_INTEGER_ONLY(and)
-BINARY_OP_NUMBER_ONLY(and)
-BINARY_OP(and)
-
-BINARY_OP_INTEGER_ONLY(or)
-BINARY_OP_NUMBER_ONLY(or)
-BINARY_OP(or)
-
-BINARY_OP_INTEGER_ONLY(xor)
-BINARY_OP_NUMBER_ONLY(xor)
-BINARY_OP(xor)
-
-BINARY_OP_FIXNUM(shift)
-
-BINARY_OP_NUMBER_ONLY(less)
-BINARY_OP(less)
-
-BINARY_OP_NUMBER_ONLY(lesseq)
-BINARY_OP(lesseq)
-
-BINARY_OP_NUMBER_ONLY(greater)
-BINARY_OP(greater)
-
-BINARY_OP_NUMBER_ONLY(greatereq)
-BINARY_OP(greatereq)
-
-UNARY_OP_INTEGER_ONLY(not)
-UNARY_OP_NUMBER_ONLY(not)
-UNARY_OP(not)
#include "factor.h"
CELL upgraded_arithmetic_type(CELL type1, CELL type2);
+void primitive_arithmetic_type(void);
CELL tag_integer(FIXNUM x);
CELL tag_cell(CELL x);
CELL to_cell(CELL x);
-#define BINARY_OP(OP) \
-CELL OP(CELL x, CELL y) \
-{ \
- switch(upgraded_arithmetic_type(type_of(x),type_of(y))) \
- { \
- case FIXNUM_TYPE: \
- return OP##_fixnum(untag_fixnum_fast(x),untag_fixnum_fast(y)); \
- case BIGNUM_TYPE: \
- return OP##_bignum(to_bignum(x),to_bignum(y)); \
- case RATIO_TYPE: \
- return OP##_ratio(to_ratio(x),to_ratio(y)); \
- case FLOAT_TYPE: \
- return OP##_float(to_float(x),to_float(y)); \
- case COMPLEX_TYPE: \
- return OP##_complex(to_complex(x),to_complex(y)); \
- default: \
- return OP##_anytype(x,y); \
- } \
-} \
-\
-void primitive_##OP(void) \
-{ \
- CELL y = dpop(), x = dpop(); \
- dpush(OP(x,y)); \
-}
-
-#define BINARY_OP_FIXNUM(OP) \
-CELL OP(CELL x, FIXNUM y) \
-{ \
- switch(type_of(x)) \
- { \
- case FIXNUM_TYPE: \
- return OP##_fixnum(untag_fixnum_fast(x),y); \
- case BIGNUM_TYPE: \
- return OP##_bignum((ARRAY*)UNTAG(x),y); \
- default: \
- type_error(INTEGER_TYPE,x); \
- return F; \
- } \
-} \
-\
-void primitive_##OP(void) \
-{ \
- CELL y = dpop(), x = dpop(); \
- dpush(OP(x,to_fixnum(y))); \
-}
-
-#define BINARY_OP_INTEGER_ONLY(OP) \
-\
-CELL OP##_ratio(RATIO* x, RATIO* y) \
-{ \
- type_error(INTEGER_TYPE,tag_ratio(x)); \
- return F; \
-} \
-\
-CELL OP##_complex(COMPLEX* x, COMPLEX* y) \
-{ \
- type_error(INTEGER_TYPE,tag_complex(x)); \
- return F; \
-} \
-\
-CELL OP##_float(FLOAT* x, FLOAT* y) \
-{ \
- type_error(INTEGER_TYPE,tag_object(x)); \
- return F; \
-}
-
-#define BINARY_OP_NUMBER_ONLY(OP) \
-\
-CELL OP##_anytype(CELL x, CELL y) \
-{ \
- type_error(NUMBER_TYPE,x); \
- return F; \
-}
-
-#define UNARY_OP(OP) \
-CELL OP(CELL x) \
-{ \
- switch(type_of(x)) \
- { \
- case FIXNUM_TYPE: \
- return OP##_fixnum(untag_fixnum_fast(x)); \
- case RATIO_TYPE: \
- return OP##_ratio((RATIO*)UNTAG(x)); \
- case COMPLEX_TYPE: \
- return OP##_complex((COMPLEX*)UNTAG(x)); \
- case BIGNUM_TYPE: \
- return OP##_bignum((ARRAY*)UNTAG(x)); \
- case FLOAT_TYPE: \
- return OP##_float((FLOAT*)UNTAG(x)); \
- default: \
- return OP##_anytype(x); \
- } \
-} \
-\
-void primitive_##OP(void) \
-{ \
- drepl(OP(dpeek())); \
-}
-
-#define UNARY_OP_INTEGER_ONLY(OP) \
-\
-CELL OP##_ratio(RATIO* x) \
-{ \
- type_error(INTEGER_TYPE,tag_ratio(x)); \
- return F; \
-} \
-\
-CELL OP##_complex(COMPLEX* x) \
-{ \
- type_error(INTEGER_TYPE,tag_complex(x)); \
- return F; \
-} \
-\
-CELL OP##_float(FLOAT* x) \
-{ \
- type_error(INTEGER_TYPE,tag_object(x)); \
- return F; \
-}
-
-#define UNARY_OP_NUMBER_ONLY(OP) \
-\
-CELL OP##_anytype(CELL x) \
-{ \
- type_error(NUMBER_TYPE,x); \
- return F; \
-}
-
bool realp(CELL tagged);
void primitive_numberp(void);
bool zerop(CELL tagged);
bool onep(CELL tagged);
-
-void primitive_to_fixnum(void);
-void primitive_to_bignum(void);
-void primitive_to_integer(void);
-CELL number_eq(CELL x, CELL y);
-void primitive_number_eq(void);
-CELL add(CELL x, CELL y);
-void primitive_add(void);
-CELL subtract(CELL x, CELL y);
-void primitive_subtract(void);
-CELL multiply(CELL x, CELL y);
-void primitive_multiply(void);
-CELL divide(CELL x, CELL y);
-void primitive_divmod(void);
-CELL divint(CELL x, CELL y);
-void primitive_divint(void);
-CELL divfloat(CELL x, CELL y);
-void primitive_divfloat(void);
-CELL divide(CELL x, CELL y);
-void primitive_divide(void);
-CELL less(CELL x, CELL y);
-void primitive_less(void);
-CELL lesseq(CELL x, CELL y);
-void primitive_lesseq(void);
-CELL greater(CELL x, CELL y);
-void primitive_greater(void);
-CELL greatereq(CELL x, CELL y);
-void primitive_greatereq(void);
-CELL mod(CELL x, CELL y);
-void primitive_mod(void);
-CELL and(CELL x, CELL y);
-void primitive_and(void);
-CELL or(CELL x, CELL y);
-void primitive_or(void);
-CELL xor(CELL x, CELL y);
-void primitive_xor(void);
-CELL shift(CELL x, FIXNUM y);
-void primitive_shift(void);
-CELL gcd(CELL x, CELL y);
-void primitive_not(void);
ARRAY* to_bignum(CELL tagged)
{
RATIO* r;
+ ARRAY* x;
+ ARRAY* y;
FLOAT* f;
switch(type_of(tagged))
return (ARRAY*)UNTAG(tagged);
case RATIO_TYPE:
r = (RATIO*)UNTAG(tagged);
- return to_bignum(divint(r->numerator,r->denominator));
+ x = to_bignum(r->numerator);
+ y = to_bignum(r->denominator);
+ return s48_bignum_quotient(x,y);
case FLOAT_TYPE:
f = (FLOAT*)UNTAG(tagged);
return s48_double_to_bignum(f->n);
drepl(tag_object(to_bignum(dpeek())));
}
-CELL number_eq_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_eq(void)
{
- return tag_boolean(s48_bignum_equal_p(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_boolean(s48_bignum_equal_p(x,y)));
}
-CELL add_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_add(void)
{
- return tag_object(s48_bignum_add(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_add(x,y)));
}
-CELL subtract_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_subtract(void)
{
- return tag_object(s48_bignum_subtract(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_subtract(x,y)));
}
-CELL multiply_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_multiply(void)
{
- return tag_object(s48_bignum_multiply(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_multiply(x,y)));
}
-CELL gcd_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_divint(void)
{
- ARRAY* t;
-
- if(BIGNUM_NEGATIVE_P(x))
- x = s48_bignum_negate(x);
- if(BIGNUM_NEGATIVE_P(y))
- y = s48_bignum_negate(y);
-
- if(s48_bignum_compare(x,y) == bignum_comparison_greater)
- {
- t = x;
- x = y;
- y = t;
- }
-
- for(;;)
- {
- if(BIGNUM_ZERO_P(x))
- return tag_object(y);
-
- t = s48_bignum_remainder(y,x);
- y = x;
- x = t;
- }
-}
-
-CELL divide_bignum(ARRAY* x, ARRAY* y)
-{
- ARRAY* gcd;
-
- if(BIGNUM_ZERO_P(y))
- raise(SIGFPE);
-
- if(BIGNUM_NEGATIVE_P(y))
- {
- x = s48_bignum_negate(x);
- y = s48_bignum_negate(y);
- }
-
- gcd = (ARRAY*)UNTAG(gcd_bignum(x,y));
- x = s48_bignum_quotient(x,gcd);
- y = s48_bignum_quotient(y,gcd);
-
- if(BIGNUM_ONE_P(y,0))
- return tag_object(x);
- else
- {
- return tag_ratio(ratio(
- tag_object(x),
- tag_object(y)));
- }
-}
-
-CELL divint_bignum(ARRAY* x, ARRAY* y)
-{
- return tag_object(s48_bignum_quotient(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_quotient(x,y)));
}
-CELL divfloat_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_divfloat(void)
{
- return tag_object(make_float(
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(make_float(
s48_bignum_to_double(x) /
- s48_bignum_to_double(y)));
+ s48_bignum_to_double(y))));
}
-CELL divmod_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_divmod(void)
{
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
ARRAY *q, *r;
s48_bignum_divide(x,y,&q,&r);
dpush(tag_object(q));
- return tag_object(r);
+ dpush(tag_object(r));
}
-CELL mod_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_mod(void)
{
- return tag_object(s48_bignum_remainder(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_remainder(x,y)));
}
-CELL and_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_and(void)
{
- return tag_object(s48_bignum_bitwise_and(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_bitwise_and(x,y)));
}
-CELL or_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_or(void)
{
- return tag_object(s48_bignum_bitwise_ior(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_bitwise_ior(x,y)));
}
-CELL xor_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_xor(void)
{
- return tag_object(s48_bignum_bitwise_xor(x,y));
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_bitwise_xor(x,y)));
}
-CELL shift_bignum(ARRAY* x, FIXNUM y)
+void primitive_bignum_shift(void)
{
- return tag_object(s48_bignum_arithmetic_shift(x,y));
+ FIXNUM y = to_fixnum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_object(s48_bignum_arithmetic_shift(x,y)));
}
-CELL less_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_less(void)
{
- return tag_boolean(
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_boolean(
s48_bignum_compare(x,y)
- == bignum_comparison_less);
+ == bignum_comparison_less));
}
-CELL lesseq_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_lesseq(void)
{
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+
switch(s48_bignum_compare(x,y))
{
case bignum_comparison_less:
case bignum_comparison_equal:
- return T;
+ dpush(T);
+ break;
case bignum_comparison_greater:
- return F;
+ dpush(F);
+ break;
default:
critical_error("s48_bignum_compare returns bogus value",0);
- return F;
+ break;
}
}
-CELL greater_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_greater(void)
{
- return tag_boolean(
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+ dpush(tag_boolean(
s48_bignum_compare(x,y)
- == bignum_comparison_greater);
+ == bignum_comparison_greater));
}
-CELL greatereq_bignum(ARRAY* x, ARRAY* y)
+void primitive_bignum_greatereq(void)
{
+ ARRAY* y = to_bignum(dpop());
+ ARRAY* x = to_bignum(dpop());
+
switch(s48_bignum_compare(x,y))
{
case bignum_comparison_less:
- return F;
+ dpush(F);
+ break;
case bignum_comparison_equal:
case bignum_comparison_greater:
- return T;
+ dpush(T);
+ break;
default:
critical_error("s48_bignum_compare returns bogus value",0);
- return F;
+ break;
}
}
-CELL not_bignum(ARRAY* x)
+void primitive_bignum_not(void)
{
- return tag_object(s48_bignum_bitwise_not(x));
+ drepl(tag_object(s48_bignum_bitwise_not(
+ untag_bignum(dpeek()))));
}
void copy_bignum_constants(void)
ARRAY* to_bignum(CELL tagged);
void primitive_to_bignum(void);
-CELL number_eq_bignum(ARRAY* x, ARRAY* y);
-CELL add_bignum(ARRAY* x, ARRAY* y);
-CELL subtract_bignum(ARRAY* x, ARRAY* y);
-CELL multiply_bignum(ARRAY* x, ARRAY* y);
-CELL gcd_bignum(ARRAY* x, ARRAY* y);
-CELL divide_bignum(ARRAY* x, ARRAY* y);
-CELL divint_bignum(ARRAY* x, ARRAY* y);
-CELL divfloat_bignum(ARRAY* x, ARRAY* y);
-CELL divmod_bignum(ARRAY* x, ARRAY* y);
-CELL mod_bignum(ARRAY* x, ARRAY* y);
-CELL and_bignum(ARRAY* x, ARRAY* y);
-CELL or_bignum(ARRAY* x, ARRAY* y);
-CELL xor_bignum(ARRAY* x, ARRAY* y);
-CELL shift_bignum(ARRAY* x, FIXNUM y);
-CELL less_bignum(ARRAY* x, ARRAY* y);
-CELL lesseq_bignum(ARRAY* x, ARRAY* y);
-CELL greater_bignum(ARRAY* x, ARRAY* y);
-CELL greatereq_bignum(ARRAY* x, ARRAY* y);
-CELL not_bignum(ARRAY* x);
+void primitive_bignum_eq(void);
+void primitive_bignum_add(void);
+void primitive_bignum_subtract(void);
+void primitive_bignum_multiply(void);
+void primitive_bignum_divint(void);
+void primitive_bignum_divfloat(void);
+void primitive_bignum_divmod(void);
+void primitive_bignum_mod(void);
+void primitive_bignum_and(void);
+void primitive_bignum_or(void);
+void primitive_bignum_xor(void);
+void primitive_bignum_shift(void);
+void primitive_bignum_less(void);
+void primitive_bignum_lesseq(void);
+void primitive_bignum_greater(void);
+void primitive_bignum_greatereq(void);
+void primitive_bignum_not(void);
void copy_bignum_constants(void);
return complex;
}
-COMPLEX* to_complex(CELL x)
-{
- switch(type_of(x))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- case FLOAT_TYPE:
- case RATIO_TYPE:
- return complex(x,0);
- case COMPLEX_TYPE:
- return (COMPLEX*)UNTAG(x);
- default:
- type_error(NUMBER_TYPE,x);
- return NULL;
- }
-}
-
CELL possibly_complex(CELL real, CELL imaginary)
{
if(zerop(imaginary))
dpush(possibly_complex(real,imaginary));
}
-
-CELL number_eq_complex(COMPLEX* x, COMPLEX* y)
-{
- return tag_boolean(
- untag_boolean(number_eq(x->real,y->real)) &&
- untag_boolean(number_eq(x->imaginary,y->imaginary)));
-}
-
-CELL add_complex(COMPLEX* x, COMPLEX* y)
-{
- return possibly_complex(
- add(x->real,y->real),
- add(x->imaginary,y->imaginary));
-}
-
-CELL subtract_complex(COMPLEX* x, COMPLEX* y)
-{
- return possibly_complex(
- subtract(x->real,y->real),
- subtract(x->imaginary,y->imaginary));
-}
-
-CELL multiply_complex(COMPLEX* x, COMPLEX* y)
-{
- return possibly_complex(
- subtract(
- multiply(x->real,y->real),
- multiply(x->imaginary,y->imaginary)),
- add(
- multiply(x->real,y->imaginary),
- multiply(x->imaginary,y->real)));
-}
-
-#define COMPLEX_DIVIDE(x,y) \
-\
- CELL mag = add( \
- multiply(y->real,y->real), \
- multiply(y->imaginary,y->imaginary)); \
-\
- CELL r = add( \
- multiply(x->real,y->real), \
- multiply(x->imaginary,y->imaginary)); \
- CELL i = subtract( \
- multiply(x->imaginary,y->real), \
- multiply(x->real,y->imaginary));
-
-CELL divide_complex(COMPLEX* x, COMPLEX* y)
-{
- COMPLEX_DIVIDE(x,y);
- return possibly_complex(divide(r,mag),divide(i,mag));
-}
-
-CELL divfloat_complex(COMPLEX* x, COMPLEX* y)
-{
- COMPLEX_DIVIDE(x,y);
- return possibly_complex(divfloat(r,mag),divfloat(i,mag));
-}
-
-#define INCOMPARABLE(x,y) general_error(ERROR_INCOMPARABLE, \
- cons(RETAG(x,COMPLEX_TYPE),RETAG(y,COMPLEX_TYPE)));
-
-CELL less_complex(COMPLEX* x, COMPLEX* y)
-{
- INCOMPARABLE(x,y);
- return F;
-}
-
-CELL lesseq_complex(COMPLEX* x, COMPLEX* y)
-{
- INCOMPARABLE(x,y);
- return F;
-}
-
-CELL greater_complex(COMPLEX* x, COMPLEX* y)
-{
- INCOMPARABLE(x,y);
- return F;
-}
-
-CELL greatereq_complex(COMPLEX* x, COMPLEX* y)
-{
- INCOMPARABLE(x,y);
- return F;
-}
#define ERROR_UNDEFINED_WORD (5<<3)
#define ERROR_TYPE (6<<3)
#define ERROR_RANGE (7<<3)
-#define ERROR_INCOMPARABLE (8<<3)
-#define ERROR_FLOAT_FORMAT (9<<3)
-#define ERROR_SIGNAL (10<<3)
-#define ERROR_PROFILING_DISABLED (11<<3)
-#define ERROR_NEGATIVE_ARRAY_SIZE (12<<3)
-#define ERROR_BAD_PRIMITIVE (13<<3)
-#define ERROR_C_STRING (14<<3)
-#define ERROR_FFI_DISABLED (15<<3)
-#define ERROR_FFI (16<<3)
+#define ERROR_FLOAT_FORMAT (8<<3)
+#define ERROR_SIGNAL (9<<3)
+#define ERROR_PROFILING_DISABLED (10<<3)
+#define ERROR_NEGATIVE_ARRAY_SIZE (11<<3)
+#define ERROR_BAD_PRIMITIVE (12<<3)
+#define ERROR_C_STRING (13<<3)
+#define ERROR_FFI_DISABLED (14<<3)
+#define ERROR_FFI (15<<3)
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
FIXNUM to_fixnum(CELL tagged)
{
RATIO* r;
+ ARRAY* x;
+ ARRAY* y;
FLOAT* f;
switch(type_of(tagged))
return (FIXNUM)s48_bignum_to_long((ARRAY*)UNTAG(tagged));
case RATIO_TYPE:
r = (RATIO*)UNTAG(tagged);
- return to_fixnum(divint(r->numerator,r->denominator));
+ x = to_bignum(r->numerator);
+ y = to_bignum(r->denominator);
+ return to_fixnum(tag_object(s48_bignum_quotient(x,y)));
case FLOAT_TYPE:
f = (FLOAT*)UNTAG(tagged);
return (FIXNUM)f->n;
drepl(tag_fixnum(to_fixnum(dpeek())));
}
-CELL number_eq_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_eq(void)
{
- return tag_boolean(x == y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_boolean(x == y));
}
-CELL add_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_add(void)
{
- return tag_integer(x + y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_integer(x + y));
}
-CELL subtract_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_subtract(void)
{
- return tag_integer(x - y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_integer(x - y));
}
/**
* Multiply two integers, and trap overflow.
* Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
*/
-CELL multiply_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_multiply(void)
{
- FIXNUM prod;
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
if(x == 0 || y == 0)
- return tag_fixnum(0);
-
- prod = x * y;
- /* if this is not equal, we have overflow */
- if(prod / x == y)
- return tag_integer(prod);
-
- return tag_object(
- s48_bignum_multiply(
- s48_long_to_bignum(x),
- s48_long_to_bignum(y)));
-}
-
-CELL divint_fixnum(FIXNUM x, FIXNUM y)
-{
- return tag_integer(x / y);
-}
-
-CELL divfloat_fixnum(FIXNUM x, FIXNUM y)
-{
- return tag_object(make_float((double)x / (double)y));
+ dpush(tag_fixnum(0));
+ else
+ {
+ FIXNUM prod = x * y;
+ /* if this is not equal, we have overflow */
+ if(prod / x == y)
+ dpush(tag_integer(prod));
+ else
+ {
+ dpush(tag_object(
+ s48_bignum_multiply(
+ s48_long_to_bignum(x),
+ s48_long_to_bignum(y))));
+ }
+ }
}
-CELL divmod_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_divint(void)
{
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
dpush(tag_integer(x / y));
- return tag_integer(x % y);
}
-CELL mod_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_divfloat(void)
{
- return tag_fixnum(x % y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_object(make_float((double)x / (double)y)));
}
-FIXNUM gcd_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_divmod(void)
{
- FIXNUM t;
-
- if(x < 0)
- x = -x;
- if(y < 0)
- y = -y;
-
- if(x > y)
- {
- t = x;
- x = y;
- y = t;
- }
-
- for(;;)
- {
- if(x == 0)
- return y;
-
- t = y % x;
- y = x;
- x = t;
- }
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_integer(x / y));
+ dpush(tag_integer(x % y));
}
-CELL divide_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_mod(void)
{
- FIXNUM gcd;
-
- if(y == 0)
- raise(SIGFPE);
- else if(y < 0)
- {
- x = -x;
- y = -y;
- }
-
- gcd = gcd_fixnum(x,y);
- if(gcd != 1)
- {
- x /= gcd;
- y /= gcd;
- }
-
- if(y == 1)
- return tag_integer(x);
- else
- {
- return tag_ratio(ratio(
- tag_integer(x),
- tag_integer(y)));
- }
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_fixnum(x % y));
}
-CELL and_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_and(void)
{
- return tag_fixnum(x & y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_fixnum(x & y));
}
-CELL or_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_or(void)
{
- return tag_fixnum(x | y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_fixnum(x | y));
}
-CELL xor_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_xor(void)
{
- return tag_fixnum(x ^ y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_fixnum(x ^ y));
}
/*
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-CELL shift_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_shift(void)
{
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+
if(y < 0)
{
if(y <= -WORD_SIZE)
- return (x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
+ dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
else
- return tag_fixnum(x >> -y);
+ dpush(tag_fixnum(x >> -y));
+ return;
}
else if(y == 0)
- return tag_fixnum(x);
+ {
+ dpush(tag_fixnum(x));
+ return;
+ }
else if(y < WORD_SIZE - TAG_BITS)
{
FIXNUM mask = (1 << (WORD_SIZE - 1 - TAG_BITS - y));
mask = -mask;
if((x & mask) == 0)
- return tag_fixnum(x << y);
+ {
+ dpush(tag_fixnum(x << y));
+ return;
+ }
}
- return tag_object(s48_bignum_arithmetic_shift(
- s48_long_to_bignum(x),y));
+ dpush(tag_object(s48_bignum_arithmetic_shift(
+ s48_long_to_bignum(x),y)));
}
-CELL less_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_less(void)
{
- return tag_boolean(x < y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_boolean(x < y));
}
-CELL lesseq_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_lesseq(void)
{
- return tag_boolean(x <= y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_boolean(x <= y));
}
-CELL greater_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_greater(void)
{
- return tag_boolean(x > y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_boolean(x > y));
}
-CELL greatereq_fixnum(FIXNUM x, FIXNUM y)
+void primitive_fixnum_greatereq(void)
{
- return tag_boolean(x >= y);
+ FIXNUM y = to_fixnum(dpop());
+ FIXNUM x = to_fixnum(dpop());
+ dpush(tag_boolean(x >= y));
}
-CELL not_fixnum(FIXNUM x)
+void primitive_fixnum_not(void)
{
- return tag_fixnum(~x);
+ drepl(tag_fixnum(~to_fixnum(dpeek())));
}
FIXNUM to_fixnum(CELL tagged);
void primitive_to_fixnum(void);
-CELL number_eq_fixnum(FIXNUM x, FIXNUM y);
-CELL add_fixnum(FIXNUM x, FIXNUM y);
-CELL subtract_fixnum(FIXNUM x, FIXNUM y);
-CELL multiply_fixnum(FIXNUM x, FIXNUM y);
-FIXNUM gcd_fixnum(FIXNUM x, FIXNUM y);
-CELL divide_fixnum(FIXNUM x, FIXNUM y);
-CELL divint_fixnum(FIXNUM x, FIXNUM y);
-CELL divfloat_fixnum(FIXNUM x, FIXNUM y);
-CELL divmod_fixnum(FIXNUM x, FIXNUM y);
-CELL mod_fixnum(FIXNUM x, FIXNUM y);
-CELL and_fixnum(FIXNUM x, FIXNUM y);
-CELL or_fixnum(FIXNUM x, FIXNUM y);
-CELL xor_fixnum(FIXNUM x, FIXNUM y);
-CELL shift_fixnum(FIXNUM x, FIXNUM y);
-CELL less_fixnum(FIXNUM x, FIXNUM y);
-CELL lesseq_fixnum(FIXNUM x, FIXNUM y);
-CELL greater_fixnum(FIXNUM x, FIXNUM y);
-CELL greatereq_fixnum(FIXNUM x, FIXNUM y);
-CELL not_fixnum(FIXNUM n);
+void primitive_fixnum_eq(void);
+void primitive_fixnum_add(void);
+void primitive_fixnum_subtract(void);
+void primitive_fixnum_multiply(void);
+void primitive_fixnum_divint(void);
+void primitive_fixnum_divfloat(void);
+void primitive_fixnum_divmod(void);
+void primitive_fixnum_mod(void);
+void primitive_fixnum_and(void);
+void primitive_fixnum_or(void);
+void primitive_fixnum_xor(void);
+void primitive_fixnum_shift(void);
+void primitive_fixnum_less(void);
+void primitive_fixnum_lesseq(void);
+void primitive_fixnum_greater(void);
+void primitive_fixnum_greatereq(void);
+void primitive_fixnum_not(void);
#include "factor.h"
-FLOAT* to_float(CELL tagged)
+double to_float(CELL tagged)
{
RATIO* r;
+ double x;
+ double y;
switch(type_of(tagged))
{
case FIXNUM_TYPE:
- return make_float((double)untag_fixnum_fast(tagged));
+ return (double)untag_fixnum_fast(tagged);
case BIGNUM_TYPE:
- return make_float(s48_bignum_to_double((ARRAY*)UNTAG(tagged)));
+ return s48_bignum_to_double((ARRAY*)UNTAG(tagged));
case RATIO_TYPE:
r = (RATIO*)UNTAG(tagged);
- return (FLOAT*)UNTAG(divfloat(r->numerator,r->denominator));
+ x = to_float(r->numerator);
+ y = to_float(r->denominator);
+ return x / y;
case FLOAT_TYPE:
- return (FLOAT*)UNTAG(tagged);
+ return ((FLOAT*)UNTAG(tagged))->n;
default:
type_error(FLOAT_TYPE,tagged);
- return NULL; /* can't happen */
+ return 0.0; /* can't happen */
}
}
void primitive_to_float(void)
{
- drepl(tag_object(to_float(dpeek())));
+ drepl(tag_object(make_float(to_float(dpeek()))));
}
void primitive_str_to_float(void)
void primitive_float_to_str(void)
{
char tmp[33];
- snprintf(tmp,32,"%.16g",to_float(dpeek())->n);
+ snprintf(tmp,32,"%.16g",to_float(dpeek()));
tmp[32] = '\0';
drepl(tag_object(from_c_string(tmp)));
}
drepl(tag_object(s48_long_long_to_bignum(f_raw)));
}
-CELL number_eq_float(FLOAT* x, FLOAT* y)
+void primitive_float_eq(void)
{
- return tag_boolean(x->n == y->n);
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_boolean(x == y));
}
-CELL add_float(FLOAT* x, FLOAT* y)
+void primitive_float_add(void)
{
- return tag_object(make_float(x->n + y->n));
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_object(make_float(x + y)));
}
-CELL subtract_float(FLOAT* x, FLOAT* y)
+void primitive_float_subtract(void)
{
- return tag_object(make_float(x->n - y->n));
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_object(make_float(x - y)));
}
-CELL multiply_float(FLOAT* x, FLOAT* y)
+void primitive_float_multiply(void)
{
- return tag_object(make_float(x->n * y->n));
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_object(make_float(x * y)));
}
-CELL divide_float(FLOAT* x, FLOAT* y)
+void primitive_float_divfloat(void)
{
- return tag_object(make_float(x->n / y->n));
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_object(make_float(x / y)));
}
-CELL divfloat_float(FLOAT* x, FLOAT* y)
+void primitive_float_less(void)
{
- return tag_object(make_float(x->n / y->n));
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_boolean(x < y));
}
-CELL less_float(FLOAT* x, FLOAT* y)
+void primitive_float_lesseq(void)
{
- return tag_boolean(x->n < y->n);
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_boolean(x <= y));
}
-CELL lesseq_float(FLOAT* x, FLOAT* y)
+void primitive_float_greater(void)
{
- return tag_boolean(x->n <= y->n);
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_boolean(x > y));
}
-CELL greater_float(FLOAT* x, FLOAT* y)
+void primitive_float_greatereq(void)
{
- return tag_boolean(x->n > y->n);
-}
-
-CELL greatereq_float(FLOAT* x, FLOAT* y)
-{
- return tag_boolean(x->n >= y->n);
+ double y = to_float(dpop());
+ double x = to_float(dpop());
+ dpush(tag_boolean(x >= y));
}
void primitive_facos(void)
{
- drepl(tag_object(make_float(acos(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(acos(to_float(dpeek())))));
}
void primitive_fasin(void)
{
- drepl(tag_object(make_float(asin(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(asin(to_float(dpeek())))));
}
void primitive_fatan(void)
{
- drepl(tag_object(make_float(atan(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(atan(to_float(dpeek())))));
}
void primitive_fatan2(void)
{
- double x = to_float(dpop())->n;
- double y = to_float(dpop())->n;
+ double x = to_float(dpop());
+ double y = to_float(dpop());
dpush(tag_object(make_float(atan2(y,x))));
}
void primitive_fcos(void)
{
- drepl(tag_object(make_float(cos(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(cos(to_float(dpeek())))));
}
void primitive_fexp(void)
{
- drepl(tag_object(make_float(exp(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(exp(to_float(dpeek())))));
}
void primitive_fcosh(void)
{
- drepl(tag_object(make_float(cosh(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(cosh(to_float(dpeek())))));
}
void primitive_flog(void)
{
- drepl(tag_object(make_float(log(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(log(to_float(dpeek())))));
}
void primitive_fpow(void)
{
- double x = to_float(dpop())->n;
- double y = to_float(dpop())->n;
+ double x = to_float(dpop());
+ double y = to_float(dpop());
dpush(tag_object(make_float(pow(y,x))));
}
void primitive_fsin(void)
{
- drepl(tag_object(make_float(sin(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(sin(to_float(dpeek())))));
}
void primitive_fsinh(void)
{
- drepl(tag_object(make_float(sinh(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(sinh(to_float(dpeek())))));
}
void primitive_fsqrt(void)
{
- drepl(tag_object(make_float(sqrt(to_float(dpeek())->n))));
+ drepl(tag_object(make_float(sqrt(to_float(dpeek())))));
}
return untag_float_fast(tagged);
}
-FLOAT* to_float(CELL tagged);
+double to_float(CELL tagged);
void primitive_to_float(void);
void primitive_str_to_float(void);
void primitive_float_to_str(void);
void primitive_float_to_bits(void);
-CELL number_eq_float(FLOAT* x, FLOAT* y);
-CELL add_float(FLOAT* x, FLOAT* y);
-CELL subtract_float(FLOAT* x, FLOAT* y);
-CELL multiply_float(FLOAT* x, FLOAT* y);
-CELL divide_float(FLOAT* x, FLOAT* y);
-CELL divfloat_float(FLOAT* x, FLOAT* y);
-CELL less_float(FLOAT* x, FLOAT* y);
-CELL lesseq_float(FLOAT* x, FLOAT* y);
-CELL greater_float(FLOAT* x, FLOAT* y);
-CELL greatereq_float(FLOAT* x, FLOAT* y);
+void primitive_float_eq(void);
+void primitive_float_add(void);
+void primitive_float_subtract(void);
+void primitive_float_multiply(void);
+void primitive_float_divfloat(void);
+void primitive_float_less(void);
+void primitive_float_lesseq(void);
+void primitive_float_greater(void);
+void primitive_float_greatereq(void);
void primitive_facos(void);
void primitive_fasin(void);
primitive_sbuf_reverse,
primitive_sbuf_clone,
primitive_sbuf_eq,
+ primitive_arithmetic_type,
primitive_numberp,
primitive_to_fixnum,
primitive_to_bignum,
primitive_to_float,
- primitive_number_eq,
primitive_numerator,
primitive_denominator,
primitive_to_fraction,
primitive_imaginary,
primitive_to_rect,
primitive_from_rect,
- primitive_add,
- primitive_subtract,
- primitive_multiply,
- primitive_divint,
- primitive_divfloat,
- primitive_divide,
- primitive_mod,
- primitive_divmod,
- primitive_and,
- primitive_or,
- primitive_xor,
- primitive_not,
- primitive_shift,
- primitive_less,
- primitive_lesseq,
- primitive_greater,
- primitive_greatereq,
+ primitive_fixnum_eq,
+ primitive_fixnum_add,
+ primitive_fixnum_subtract,
+ primitive_fixnum_multiply,
+ primitive_fixnum_divint,
+ primitive_fixnum_divfloat,
+ primitive_fixnum_mod,
+ primitive_fixnum_divmod,
+ primitive_fixnum_and,
+ primitive_fixnum_or,
+ primitive_fixnum_xor,
+ primitive_fixnum_not,
+ primitive_fixnum_shift,
+ primitive_fixnum_less,
+ primitive_fixnum_lesseq,
+ primitive_fixnum_greater,
+ primitive_fixnum_greatereq,
+ primitive_bignum_eq,
+ primitive_bignum_add,
+ primitive_bignum_subtract,
+ primitive_bignum_multiply,
+ primitive_bignum_divint,
+ primitive_bignum_divfloat,
+ primitive_bignum_mod,
+ primitive_bignum_divmod,
+ primitive_bignum_and,
+ primitive_bignum_or,
+ primitive_bignum_xor,
+ primitive_bignum_not,
+ primitive_bignum_shift,
+ primitive_bignum_less,
+ primitive_bignum_lesseq,
+ primitive_bignum_greater,
+ primitive_bignum_greatereq,
+ primitive_float_eq,
+ primitive_float_add,
+ primitive_float_subtract,
+ primitive_float_multiply,
+ primitive_float_divfloat,
+ primitive_float_less,
+ primitive_float_lesseq,
+ primitive_float_greater,
+ primitive_float_greatereq,
primitive_facos,
primitive_fasin,
primitive_fatan,
extern XT primitives[];
-#define PRIMITIVE_COUNT 163
+#define PRIMITIVE_COUNT 181
CELL primitive_to_xt(CELL primitive);
raise(SIGFPE);
if(onep(denominator))
dpush(numerator);
- dpush(tag_ratio(ratio(numerator,denominator)));
-}
-
-RATIO* to_ratio(CELL x)
-{
- switch(type_of(x))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- return ratio(x,tag_fixnum(1));
- case RATIO_TYPE:
- return (RATIO*)UNTAG(x);
- default:
- type_error(RATIONAL_TYPE,x);
- return NULL;
- }
+ else
+ dpush(tag_ratio(ratio(numerator,denominator)));
}
void primitive_to_fraction(void)
break;
}
}
-
-CELL number_eq_ratio(RATIO* x, RATIO* y)
-{
- return tag_boolean(
- untag_boolean(number_eq(x->numerator,y->numerator)) &&
- untag_boolean(number_eq(x->denominator,y->denominator)));
-}
-
-CELL add_ratio(RATIO* x, RATIO* y)
-{
- return divide(add(multiply(x->numerator,y->denominator),
- multiply(x->denominator,y->numerator)),
- multiply(x->denominator,y->denominator));
-}
-
-CELL subtract_ratio(RATIO* x, RATIO* y)
-{
- return divide(subtract(multiply(x->numerator,y->denominator),
- multiply(x->denominator,y->numerator)),
- multiply(x->denominator,y->denominator));
-}
-
-CELL multiply_ratio(RATIO* x, RATIO* y)
-{
- return divide(
- multiply(x->numerator,y->numerator),
- multiply(x->denominator,y->denominator));
-}
-
-CELL divide_ratio(RATIO* x, RATIO* y)
-{
- return divide(
- multiply(x->numerator,y->denominator),
- multiply(x->denominator,y->numerator));
-}
-
-CELL divfloat_ratio(RATIO* x, RATIO* y)
-{
- return divfloat(
- multiply(x->numerator,y->denominator),
- multiply(x->denominator,y->numerator));
-}
-
-CELL less_ratio(RATIO* x, RATIO* y)
-{
- return less(multiply(x->numerator,y->denominator),
- multiply(y->numerator,x->denominator));
-}
-
-CELL lesseq_ratio(RATIO* x, RATIO* y)
-{
- return lesseq(multiply(x->numerator,y->denominator),
- multiply(y->numerator,x->denominator));
-}
-
-CELL greater_ratio(RATIO* x, RATIO* y)
-{
- return greater(multiply(x->numerator,y->denominator),
- multiply(y->numerator,x->denominator));
-}
-
-CELL greatereq_ratio(RATIO* x, RATIO* y)
-{
- return greatereq(multiply(x->numerator,y->denominator),
- multiply(y->numerator,x->denominator));
-}
projects / factor.git / commitdiff