>fixnum >bignum >float primitives split up into smaller sub-primitives and are now generic words in the library

TODO.FACTOR.txt

@@ -4,7 +4,6 @@
 - what if retain stack is full
   - ie, inside retain stack overflow handler, don't cons?
 - os-windows.c error_message &co
-- to_float, to_fixnum, to_bignum: don't cons
 - inline float allocation needs a gc check
 - alien invoke, callback need a gc check
 - relocation should not cons at all

library/bootstrap/primitives.factor

@@ -43,9 +43,12 @@ call
     { "dispatch" "kernel-internals"         }
     { "rehash-string" "strings"             }
     { "string>sbuf" "strings"               }
-    { ">fixnum" "math"                      }
+    { "bignum>fixnum" "math-internals"      }
-    { ">bignum" "math"                      }
+    { "float>fixnum" "math-internals"       }
-    { ">float" "math"                       }
+    { "fixnum>bignum" "math-internals"      }
+    { "float>bignum" "math-internals"       }
+    { "fixnum>float" "math-internals"       }
+    { "bignum>float" "math-internals"       }
     { "(fraction>)" "math-internals"        }
     { "string>float" "math-internals"       }
     { "float>string" "math-internals"       }
@@ -240,11 +243,11 @@ num-types f <array> builtins set
 
 "fixnum?" "math" create t "inline" set-word-prop
 "fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
-"fixnum" "math" create ">fixnum" "math" lookup unit "coercer" set-word-prop
+"fixnum" "math" create ">fixnum" "math" create unit "coercer" set-word-prop
 
 "bignum?" "math" create t "inline" set-word-prop
 "bignum" "math" create 1 "bignum?" "math" create { } define-builtin
-"bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
+"bignum" "math" create ">bignum" "math" create unit "coercer" set-word-prop
 
 "word?" "words" create t "inline" set-word-prop
 "word" "words" create 2 "word?" "words" create
@@ -297,7 +300,7 @@ num-types f <array> builtins set
 
 "float?" "math" create t "inline" set-word-prop
 "float" "math" create 5 "float?" "math" create { } define-builtin
-"float" "math" create ">float" "math" lookup unit "coercer" set-word-prop
+"float" "math" create ">float" "math" create unit "coercer" set-word-prop
 
 "complex?" "math" create t "inline" set-word-prop
 "complex" "math" create 6 "complex?" "math" create

library/compiler/alien/aliens.facts

@@ -1,5 +1,5 @@
 IN: alien
-USING: help ;
+USING: arrays help ;
 
 HELP: alien
 { $class-description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-objects" } " for general information." } ;
@@ -24,7 +24,7 @@ $terpri
 HELP: alien-address ( c-ptr -- addr )
 { $values { "c-ptr" "an alien or " { $link f } } { "addr" "a non-negative integer" } }
 { $description "Outputs the address of an alien." }
-{ $note "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
+{ $notes "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
 
 HELP: <alien>
 { $values { "address" "a non-negative integer" } { "alien" "a new alien address" } }

library/compiler/inference/known-words.factor

@@ -71,14 +71,23 @@ t over set-effect-terminated?
 
 \ string>sbuf { string } { sbuf } <effect> "infer-effect" set-word-prop
 
-\ >fixnum { real } { fixnum } <effect> "infer-effect" set-word-prop
+\ bignum>fixnum { bignum } { fixnum } <effect> "infer-effect" set-word-prop
-\ >fixnum t "foldable" set-word-prop
+\ bignum>fixnum t "foldable" set-word-prop
 
-\ >bignum { real } { bignum } <effect> "infer-effect" set-word-prop
+\ float>fixnum { float } { fixnum } <effect> "infer-effect" set-word-prop
-\ >bignum t "foldable" set-word-prop
+\ bignum>fixnum t "foldable" set-word-prop
 
-\ >float { real } { float } <effect> "infer-effect" set-word-prop
+\ fixnum>bignum { fixnum } { bignum } <effect> "infer-effect" set-word-prop
-\ >float t "foldable" set-word-prop
+\ fixnum>bignum t "foldable" set-word-prop
+
+\ float>bignum { float } { bignum } <effect> "infer-effect" set-word-prop
+\ float>bignum t "foldable" set-word-prop
+
+\ fixnum>float { fixnum } { float } <effect> "infer-effect" set-word-prop
+\ fixnum>float t "foldable" set-word-prop
+
+\ bignum>float { bignum } { float } <effect> "infer-effect" set-word-prop
+\ bignum>float t "foldable" set-word-prop
 
 \ (fraction>) { integer integer } { rational } <effect> "infer-effect" set-word-prop
 \ (fraction>) t "foldable" set-word-prop

library/math/constants.factor

@@ -26,3 +26,7 @@ IN: math
 
 : most-positive-fixnum ( -- n ) first-bignum 1- ;
 : most-negative-fixnum ( -- n ) first-bignum neg ;
+
+M: float >integer
+    dup most-negative-fixnum most-positive-fixnum between?
+    [ >fixnum ] [ >bignum ] if ;

library/math/float.factor

@@ -23,6 +23,10 @@ M: real <=> - ;
 M: float zero?
     dup 0.0 float= swap -0.0 float= or ;
 
+M: float >fixnum float>fixnum ;
+M: float >bignum float>bignum ;
+M: float >float ;
+
 M: float < float< ;
 M: float <= float<= ;
 M: float > float> ;

library/math/integer.factor

@@ -52,6 +52,12 @@ M: integer /
         2dup gcd nip tuck /i >r /i r> fraction>
     ] if ;
 
+M: integer >integer ;
+
+M: fixnum >fixnum ;
+M: fixnum >bignum fixnum>bignum ;
+M: fixnum >float fixnum>float ;
+
 M: fixnum number= eq? ;
 
 M: fixnum < fixnum< ;
@@ -75,6 +81,10 @@ M: fixnum shift >fixnum fixnum-shift ;
 
 M: fixnum bitnot fixnum-bitnot ;
 
+M: bignum >fixnum bignum>fixnum ;
+M: bignum >bignum ;
+M: bignum >float bignum>float ;
+
 M: bignum number= bignum= ;
 M: bignum < bignum< ;
 M: bignum <= bignum<= ;

library/math/math.factor

@@ -3,6 +3,11 @@
 IN: math
 USING: errors generic kernel math-internals ;
 
+GENERIC: >integer ( x -- y ) foldable
+GENERIC: >fixnum ( x -- y ) foldable
+GENERIC: >bignum ( x -- y ) foldable
+GENERIC: >float ( x -- y ) foldable
+
 G: number= ( x y -- ? ) math-combination ; foldable
 M: object number= 2drop f ;
 

library/math/ratio.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: math
 USING: generic kernel kernel-internals math math-internals ;
 
@@ -25,6 +25,12 @@ M: ratio number=
 : ratio+d ( a/b c/d -- b*d )
     denominator swap denominator * ; inline
 
+M: ratio >integer >fraction /i ;
+M: ratio >float >fraction /f ;
+
+M: ratio >fixnum >integer >fixnum ;
+M: ratio >bignum >integer >bignum ;
+
 M: ratio < scale < ;
 M: ratio <= scale <= ;
 M: ratio > scale > ;

vm/factor.h

@@ -21,8 +21,8 @@
 #include "bignumint.h"
 #include "bignum.h"
 #include "data_gc.h"
-#include "math.h"
 #include "types.h"
+#include "math.h"
 #include "io.h"
 #include "code_gc.h"
 #include "compiler.h"

vm/math.c

@@ -4,41 +4,46 @@
 
 F_FIXNUM to_fixnum(CELL tagged)
 {
-	F_RATIO* r;
-	F_ARRAY* x;
-	F_ARRAY* y;
-	F_FLOAT* f;
-
 	switch(TAG(tagged))
 	{
 	case FIXNUM_TYPE:
 		return untag_fixnum_fast(tagged);
 	case BIGNUM_TYPE:
-		return (F_FIXNUM)s48_bignum_to_fixnum((F_ARRAY*)UNTAG(tagged));
+		return bignum_to_fixnum(tagged);
-	case RATIO_TYPE:
-		r = (F_RATIO*)UNTAG(tagged);
-		x = to_bignum(r->numerator);
-		y = to_bignum(r->denominator);
-		return to_fixnum(tag_bignum(s48_bignum_quotient(x,y)));
-	case FLOAT_TYPE:
-		f = (F_FLOAT*)UNTAG(tagged);
-		return (F_FIXNUM)f->n;
 	default:
 		type_error(FIXNUM_TYPE,tagged);
 		return -1; /* can't happen */
 	}
 }
 
-void primitive_to_fixnum(void)
+CELL to_cell(CELL x)
 {
-	drepl(tag_fixnum(to_fixnum(dpeek())));
+	switch(type_of(x))
+	{
+	case FIXNUM_TYPE:
+		return untag_fixnum_fast(x);
+	case BIGNUM_TYPE:
+		return s48_bignum_to_fixnum(untag_bignum_fast(x));
+	default:
+		type_error(BIGNUM_TYPE,x);
+		return 0;
+	}
+}
+
+void primitive_bignum_to_fixnum(void)
+{
+	drepl(tag_fixnum(bignum_to_fixnum(dpeek())));
+}
+
+void primitive_float_to_fixnum(void)
+{
+	drepl(tag_fixnum(float_to_fixnum(dpeek())));
 }
 
 #define POP_FIXNUMS(x,y) \
-	F_FIXNUM x, y; \
+	F_FIXNUM y = untag_fixnum_fast(dpop()); \
-	y = untag_fixnum_fast(dpop()); \
+	F_FIXNUM x = untag_fixnum_fast(dpop());
-	x = untag_fixnum_fast(dpop());
+
-	
 /* The fixnum arithmetic operations defined in C are relatively slow.
 The Factor compiler has optimized assembly intrinsics for all these
 operations. */
@@ -222,51 +227,14 @@ INT_DEFUNBOX(unbox_unsigned_1, unsigned char)
 INT_DEFUNBOX(unbox_unsigned_2, unsigned short) 
 
 /* Bignums */
-
+void primitive_fixnum_to_bignum(void)
-CELL to_cell(CELL x)
 {
-	switch(type_of(x))
+	drepl(tag_bignum(fixnum_to_bignum(dpeek())));
-	{
-	case FIXNUM_TYPE:
-		return untag_fixnum_fast(x);
-	case BIGNUM_TYPE:
-		return s48_bignum_to_fixnum(untag_bignum_fast(x));
-	default:
-		type_error(BIGNUM_TYPE,x);
-		return 0;
-	}
 }
 
-F_ARRAY* to_bignum(CELL tagged)
+void primitive_float_to_bignum(void)
 {
-	F_RATIO* r;
+	drepl(tag_bignum(fixnum_to_bignum(dpeek())));
-	F_ARRAY* x;
-	F_ARRAY* y;
-	F_FLOAT* f;
-
-	switch(type_of(tagged))
-	{
-	case FIXNUM_TYPE:
-		return s48_fixnum_to_bignum(untag_fixnum_fast(tagged));
-	case BIGNUM_TYPE:
-		return (F_ARRAY*)UNTAG(tagged);
-	case RATIO_TYPE:
-		r = (F_RATIO*)UNTAG(tagged);
-		x = to_bignum(r->numerator);
-		y = to_bignum(r->denominator);
-		return s48_bignum_quotient(x,y);
-	case FLOAT_TYPE:
-		f = (F_FLOAT*)UNTAG(tagged);
-		return s48_double_to_bignum(f->n);
-	default:
-		type_error(BIGNUM_TYPE,tagged);
-		return NULL; /* can't happen */
-	}
-}
-
-void primitive_to_bignum(void)
-{
-	drepl(tag_bignum(to_bignum(dpeek())));
 }
 
 #define POP_BIGNUMS(x,y) \
@@ -427,7 +395,7 @@ F_FIXNUM unbox_unsigned_cell(void)
 
 void box_signed_4(s32 n)
 {
-	dpush(tag_bignum(s48_long_to_bignum(n)));
+	dpush(allot_integer(n));
 }
 
 s32 unbox_signed_4(void)
@@ -437,7 +405,7 @@ s32 unbox_signed_4(void)
 
 void box_unsigned_4(u32 n)
 {
-	dpush(tag_bignum(s48_ulong_to_bignum(n)));
+	dpush(allot_cell(n));
 }
 
 u32 unbox_unsigned_4(void)
@@ -447,22 +415,50 @@ u32 unbox_unsigned_4(void)
 
 void box_signed_8(s64 n)
 {
-	dpush(tag_bignum(s48_long_long_to_bignum(n)));
+	if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+		dpush(tag_bignum(s48_long_long_to_bignum(n)));
+	else
+		dpush(tag_fixnum(n));
 }
 
 s64 unbox_signed_8(void)
 {
-	return s48_bignum_to_long_long(to_bignum(dpop()));
+	CELL obj = dpop();
+
+	switch(type_of(obj))
+	{
+	case FIXNUM_TYPE:
+		return untag_fixnum_fast(obj);
+	case BIGNUM_TYPE:
+		return s48_bignum_to_long_long(untag_array_fast(obj));
+	default:
+		type_error(BIGNUM_TYPE,obj);
+		return -1;
+	}
 }
 
 void box_unsigned_8(u64 n)
 {
-	dpush(tag_bignum(s48_ulong_long_to_bignum(n)));
+	if(n > FIXNUM_MAX)
+		dpush(tag_bignum(s48_ulong_long_to_bignum(n)));
+	else
+		dpush(tag_fixnum(n));
 }
 
 u64 unbox_unsigned_8(void)
 {
-	return s48_bignum_to_ulong_long(to_bignum(dpop()));
+	CELL obj = dpop();
+
+	switch(type_of(obj))
+	{
+	case FIXNUM_TYPE:
+		return untag_fixnum_fast(obj);
+	case BIGNUM_TYPE:
+		return s48_bignum_to_ulong_long(untag_array_fast(obj));
+	default:
+		type_error(BIGNUM_TYPE,obj);
+		return -1;
+	}
 }
 
 /* Ratios */
@@ -478,35 +474,14 @@ void primitive_from_fraction(void)
 }
 
 /* Floats */
-
+void primitive_fixnum_to_float(void)
-double to_float(CELL tagged)
 {
-	F_RATIO* r;
+	drepl(allot_float(fixnum_to_float(dpeek())));
-	double x;
-	double y;
-
-	switch(TAG(tagged))
-	{
-	case FIXNUM_TYPE:
-		return (double)untag_fixnum_fast(tagged);
-	case BIGNUM_TYPE:
-		return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged));
-	case RATIO_TYPE:
-		r = (F_RATIO*)UNTAG(tagged);
-		x = to_float(r->numerator);
-		y = to_float(r->denominator);
-		return x / y;
-	case FLOAT_TYPE:
-		return ((F_FLOAT*)UNTAG(tagged))->n;
-	default:
-		type_error(FLOAT_TYPE,tagged);
-		return 0.0; /* can't happen */
-	}
 }
 
-void primitive_to_float(void)
+void primitive_bignum_to_float(void)
 {
-	drepl(allot_float(to_float(dpeek())));
+	drepl(allot_float(bignum_to_float(dpeek())));
 }
 
 void primitive_str_to_float(void)
@@ -634,7 +609,7 @@ void name (type flo)                                                       \
 #define FLO_DEFUNBOX(name,type) \
 type name(void)                                                                \
 {                                                                              \
-	return to_float(dpop());                                                  \
+	return untag_float(dpop());                                            \
 }
 
 FLO_DEFBOX(box_float,float)

vm/math.h

@@ -11,8 +11,16 @@ INLINE CELL tag_fixnum(F_FIXNUM untagged)
 	return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
 }
 
+INLINE F_FIXNUM bignum_to_fixnum(CELL tagged)
+{
+	return (F_FIXNUM)s48_bignum_to_fixnum(untag_array_fast(tagged));
+}
+
 F_FIXNUM to_fixnum(CELL tagged);
-void primitive_to_fixnum(void);
+CELL to_cell(CELL tagged);
+
+void primitive_bignum_to_fixnum(void);
+void primitive_float_to_fixnum(void);
 
 void primitive_fixnum_add(void);
 void primitive_fixnum_subtract(void);
@@ -55,9 +63,13 @@ INLINE CELL tag_bignum(F_ARRAY* bignum)
 	return RETAG(bignum,BIGNUM_TYPE);
 }
 
-CELL to_cell(CELL x);
+INLINE F_ARRAY *fixnum_to_bignum(CELL tagged)
-F_ARRAY* to_bignum(CELL tagged);
+{
-void primitive_to_bignum(void);
+	return s48_fixnum_to_bignum(untag_fixnum_fast(tagged));
+}
+
+void primitive_fixnum_to_bignum(void);
+void primitive_float_to_bignum(void);
 void primitive_bignum_eq(void);
 void primitive_bignum_add(void);
 void primitive_bignum_subtract(void);
@@ -129,6 +141,12 @@ INLINE double untag_float_fast(CELL tagged)
 	return ((F_FLOAT*)UNTAG(tagged))->n;
 }
 
+INLINE double untag_float(CELL tagged)
+{
+	type_check(FLOAT_TYPE,tagged);
+	return untag_float_fast(tagged);
+}
+
 INLINE CELL allot_float(double n)
 {
 	F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
@@ -136,8 +154,28 @@ INLINE CELL allot_float(double n)
 	return RETAG(flo,FLOAT_TYPE);
 }
 
-double to_float(CELL tagged);
+INLINE F_FIXNUM float_to_fixnum(CELL tagged)
-void primitive_to_float(void);
+{
+	return (F_FIXNUM)untag_float_fast(tagged);
+}
+
+INLINE F_ARRAY *float_to_bignum(CELL tagged)
+{
+	return s48_double_to_bignum(untag_float_fast(tagged));
+}
+
+INLINE double fixnum_to_float(CELL tagged)
+{
+	return (double)untag_fixnum_fast(tagged);
+}
+
+INLINE double bignum_to_float(CELL tagged)
+{
+	return s48_bignum_to_double(untag_array_fast(tagged));
+}
+
+void primitive_fixnum_to_float(void);
+void primitive_bignum_to_float(void);
 void primitive_str_to_float(void);
 void primitive_float_to_str(void);
 void primitive_float_to_bits(void);

vm/primitives.c

@@ -10,9 +10,12 @@ void* primitives[] = {
 	primitive_dispatch,
 	primitive_rehash_string,
 	primitive_string_to_sbuf,
-	primitive_to_fixnum,
+	primitive_bignum_to_fixnum,
-	primitive_to_bignum,
+	primitive_float_to_fixnum,
-	primitive_to_float,
+	primitive_fixnum_to_bignum,
+	primitive_float_to_bignum,
+	primitive_fixnum_to_float,
+	primitive_bignum_to_float,
 	primitive_from_fraction,
 	primitive_str_to_float,
 	primitive_float_to_str,

vm/stack.h

@@ -21,11 +21,6 @@ INLINE CELL dpeek(void)
 	return get(ds);
 }
 
-INLINE CELL dpeek2(void)
-{
-	return get(ds - CELLS);
-}
-
 INLINE CELL cpop(void)
 {
 	CELL value = get(cs);

vm/types.h

@@ -47,7 +47,7 @@ void primitive_become(void);
 
 INLINE CELL array_capacity(F_ARRAY* array)
 {
-	return untag_fixnum_fast(array->capacity);
+	return array->capacity >> TAG_BITS;
 }
 
 INLINE F_VECTOR* untag_vector(CELL tagged)
@@ -75,7 +75,7 @@ INLINE F_STRING* untag_string(CELL tagged)
 
 INLINE CELL string_capacity(F_STRING* str)
 {
-	return untag_fixnum_fast(str->length);
+	return str->length >> TAG_BITS;
 }
 
 INLINE CELL string_size(CELL size)