some bignum work

TODO.FACTOR.txt

@@ -1,19 +1,16 @@
 + bignums:
 
-- -1 is broken, add a test to verify this in the future
-- gcd is broken
-- bignum/ is broken
 - change shift< and shift> to ash
-- gcd is broken
 - cached 0/-1/1 should be cross compiled in image
 - bignum cross compiling
-- upgrading fixnums does not work
+- upgrading fixnums does not work with shift</shift>
 - ash is inefficient: arg 2 is upgraded to bignum then back
   to long
 - move some s48_ functions into bignum.c
 - remove unused functions
-
+- clean up type coercions in arithmetic.c
 - add a socket timeout
+
 - >lower, >upper for strings
 - telnetd should use multitasking
 - accept multi-line input in listener
@@ -62,7 +59,6 @@
 + native:
 
 - is the profiler using correct stack depth?
-- bignums
 - read1
 - sbuf-hashcode
 - vector-hashcode

library/cross-compiler.factor

@@ -58,7 +58,7 @@ IN: strings
 DEFER: str=
 DEFER: str-hashcode
 DEFER: sbuf=
-DEFER: clone-sbuf
+DEFER: sbuf-clone
 
 IN: io-internals
 DEFER: port?
@@ -138,7 +138,8 @@ IN: cross-compiler
         set-sbuf-nth
         sbuf-append
         sbuf>str
-        clone-sbuf
+        sbuf-reverse
+        sbuf-clone
         sbuf=
         number?
         >fixnum

library/platform/jvm/sbuf.factor

@@ -54,3 +54,7 @@ USE: stack
 
 : sbuf>str ( sbuf -- str )
     >str ;
+
+: sbuf-reverse ( sbuf -- )
+    #! Destructively reverse a string buffer.
+    [ ] "java.lang.StringBuffer" "reverse" jinvoke drop ;

library/platform/native/kernel.factor

@@ -71,8 +71,8 @@ USE: vectors
 : clone ( obj -- obj )
     [
         [ cons? ] [ clone-list ]
-        [ vector? ] [ clone-vector ]
-        [ sbuf? ] [ clone-sbuf ]
+        [ vector? ] [ vector-clone ]
+        [ sbuf? ] [ sbuf-clone ]
         [ drop t ] [ ( return the object ) ]
     ] cond ;
 

library/platform/native/unparser.factor

@@ -39,19 +39,23 @@ USE: stdio
 USE: strings
 USE: words
 
-: integer% ( num -- )
-    "base" get /mod swap dup 0 > [
-        integer%
+: integer% ( num radix -- )
+    tuck /mod >digit % dup 0 > [
+        swap integer%
     ] [
-        drop
-    ] ifte >digit % ;
+        2drop
+    ] ifte ;
 
 : integer- ( num -- num )
     dup 0 < [ "-" % neg ] when ;
 
 : >base ( num radix -- string )
     #! Convert a number to a string in a certain base.
-    [ "base" set <% integer- integer% %> ] with-scope ;
+    <% dup 0 < [
+        neg integer% CHAR: - %
+    ] [
+        integer%
+    ] ifte reverse%> ;
 
 : >dec ( num -- string )
     #! Convert an integer to its decimal representation.

library/sbuf.factor

@@ -53,6 +53,11 @@ USE: stack
     #! stack.
     "string-buffer" get sbuf>str n> drop ;
 
+: reverse%> ( -- str )
+     #! Ends construction and pushes the *reversed*, constructed
+     #! text on the stack.
+     "string-buffer" get dup sbuf-reverse sbuf>str n> drop ;
+
 : fill ( count char -- string )
     #! Push a string that consists of the same character
     #! repeated.

library/test/benchmark/fac.factor

@@ -0,0 +1,6 @@
+IN: scratchpad
+USE: math
+USE: stack
+USE: test
+
+[ 30000 fac drop ] time

library/test/benchmark/fib.factor

@@ -1,5 +1,6 @@
 IN: scratchpad
 USE: math
+USE: stack
 USE: test
 
-[ 35 fib ] time
+[ 35 fib drop ] time

library/test/math/bignum.factor

@@ -0,0 +1,11 @@
+IN: scratchpad
+USE: arithmetic
+USE: stack
+USE: test
+USE: unparser
+
+[ -1 ] [ -1 >bignum >fixnum ] unit-test
+
+[ "8589934592" ]
+[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
+unit-test

library/test/math/gcd.factor

@@ -0,0 +1,21 @@
+IN: scratchpad
+USE: arithmetic
+USE: test
+
+[ 100 ] [ 100 100 gcd ] unit-test
+[ 100 ] [ 1000 100 gcd ] unit-test
+[ 100 ] [ 100 1000 gcd ] unit-test
+[ 4 ] [ 132 64 gcd ] unit-test
+[ 4 ] [ -132 64 gcd ] unit-test
+[ 4 ] [ -132 -64 gcd ] unit-test
+[ 4 ] [ 132 -64 gcd ] unit-test
+[ 4 ] [ -132 -64 gcd ] unit-test
+
+[ 100 ] [ 100 >bignum 100 >bignum gcd ] unit-test
+[ 100 ] [ 1000 >bignum 100 >bignum gcd ] unit-test
+[ 100 ] [ 100 >bignum 1000 >bignum gcd ] unit-test
+[ 4 ] [ 132 >bignum 64 >bignum gcd ] unit-test
+[ 4 ] [ -132 >bignum 64 >bignum gcd ] unit-test
+[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
+[ 4 ] [ 132 >bignum -64 >bignum gcd ] unit-test
+[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test

library/test/math/rational.factor

@@ -76,12 +76,3 @@ USE: test
 [ t ]
 [ 1000000000000/999999999999 1000000000001/999999999998 < ]
 unit-test
-
-[ 100 ] [ 100 100 gcd ] unit-test
-[ 100 ] [ 1000 100 gcd ] unit-test
-[ 100 ] [ 100 1000 gcd ] unit-test
-[ 4 ] [ 132 64 gcd ] unit-test
-[ 4 ] [ -132 64 gcd ] unit-test
-[ 4 ] [ -132 -64 gcd ] unit-test
-[ 4 ] [ 132 -64 gcd ] unit-test
-[ 4 ] [ -132 -64 gcd ] unit-test

library/test/strings.factor

@@ -3,6 +3,7 @@ USE: arithmetic
 USE: combinators
 USE: kernel
 USE: namespaces
+USE: stack
 USE: strings
 USE: test
 
@@ -82,6 +83,9 @@ unit-test
 [ t ] [ "abc" "abd" str-compare 0 < ] unit-test
 [ t ] [ "z" "abd" str-compare 0 > ] unit-test
 
+[ "fedcba" ] [ "abcdef" str>sbuf dup sbuf-reverse sbuf>str ] unit-test
+[ "edcba" ] [ "abcde" str>sbuf dup sbuf-reverse sbuf>str ] unit-test
+
 native? [
     [ t ] [ "Foo" str>sbuf "Foo" str>sbuf = ] unit-test
     [ f ] [ "Foo" str>sbuf "Foob" str>sbuf = ] unit-test

library/test/test.factor

@@ -83,7 +83,9 @@ USE: unparser
         "words"
         "unparser"
         "random"
+        "math/bignum"
         "math/bitops"
+        "math/gcd"
         "math/rational"
         "math/float"
         "math/complex"

library/vectors.factor

@@ -62,6 +62,6 @@ USE: stack
 
 DEFER: vector-map
 
-: clone-vector ( vector -- vector )
+: vector-clone ( vector -- vector )
     #! Shallow copy of a vector.
     [ ] vector-map ;

native/arithmetic.h

@@ -11,17 +11,10 @@ FLOAT* ratio_to_float(CELL n);
 
 #define CELL_TO_INTEGER(result) \
 	FIXNUM _result = (result); \
-	/* if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
-		return tag_object(fixnum_to_bignum(_result)); \
-	else \
-		 */return tag_fixnum(_result);
-
-#define BIGNUM_2_TO_INTEGER(result) \
-        BIGNUM_2 _result = (result); \
-        /* if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
+	if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
 		return tag_object(s48_long_to_bignum(_result)); \
 	else \
-                 */return tag_fixnum(_result);
+		return tag_fixnum(_result);
 
 #define BINARY_OP(OP) \
 CELL OP(CELL x, CELL y) \

native/bignum.c

@@ -7,7 +7,7 @@ void init_bignum(void)
 	bignum_pos_one = bignum_allocate(1,0);
 	(BIGNUM_REF (bignum_pos_one, 0)) = 1;
 
-	bignum_neg_one = bignum_allocate(1,0);
+	bignum_neg_one = bignum_allocate(1,1);
 	(BIGNUM_REF (bignum_neg_one, 0)) = 1;
 }
 
@@ -64,16 +64,16 @@ CELL multiply_bignum(ARRAY* x, ARRAY* y)
 	return tag_object(s48_bignum_multiply(x,y));
 }
 
-BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y)
+CELL gcd_bignum(ARRAY* x, ARRAY* y)
 {
-	BIGNUM_2 t;
+	ARRAY* t;
 
-	if(x < 0)
-		x = -x;
-	if(y < 0)
-		y = -y;
+	if(BIGNUM_NEGATIVE_P(x))
+		x = s48_bignum_negate(x);
+	if(BIGNUM_NEGATIVE_P(y))
+		y = s48_bignum_negate(y);
 
-	if(x > y)
+	if(s48_bignum_compare(x,y) == bignum_comparison_greater)
 	{
 		t = x;
 		x = y;
@@ -82,10 +82,10 @@ BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y)
 
 	for(;;)
 	{
-		if(x == 0)
-			return y;
+		if(BIGNUM_ZERO_P(x))
+			return tag_object(y);
 
-		t = y % x;
+		t = s48_bignum_remainder(y,x);
 		y = x;
 		x = t;
 	}
@@ -93,37 +93,29 @@ BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 y)
 
 CELL divide_bignum(ARRAY* x, ARRAY* y)
 {
-	/* BIGNUM_2 _x = x->n;
-	BIGNUM_2 _y = y->n;
-	BIGNUM_2 gcd;
+	ARRAY* gcd;
 
-	if(_y == 0)
+	if(BIGNUM_ZERO_P(y))
+		raise(SIGFPE);
+
+	if(BIGNUM_NEGATIVE_P(y))
 	{
-		/* FIXME
-		abort();
-	}
-	else if(_y < 0)
-	{
-		_x = -_x;
-		_y = -_y;
+		x = s48_bignum_negate(x);
+		y = s48_bignum_negate(y);
 	}
 
-	gcd = gcd_bignum(_x,_y);
-	if(gcd != 1)
-	{
-		_x /= gcd;
-		_y /= gcd;
-	}
+	gcd = (ARRAY*)UNTAG(gcd_bignum(x,y));
+	x = s48_bignum_quotient(x,gcd);
+	y = s48_bignum_quotient(y,gcd);
 
-	if(_y == 1)
-		return tag_object(bignum(_x));
+	if(BIGNUM_ONE_P(y,0))
+		return tag_object(x);
 	else
 	{
 		return tag_ratio(ratio(
-			tag_object(bignum(_x)),
-			tag_object(bignum(_y))));
-	} */
-	return F;
+			tag_object(x),
+			tag_object(y)));
+	}
 }
 
 CELL divint_bignum(ARRAY* x, ARRAY* y)

native/bignum.h

@@ -1,5 +1,3 @@
-typedef long long BIGNUM_2;
-
 INLINE ARRAY* untag_bignum(CELL tagged)
 {
 	type_check(BIGNUM_TYPE,tagged);
@@ -18,7 +16,7 @@ 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);
-BIGNUM_2 gcd_bignum(BIGNUM_2 x, BIGNUM_2 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);

native/fixnum.c

@@ -48,10 +48,19 @@ CELL subtract_fixnum(CELL x, CELL y)
 	CELL_TO_INTEGER(untag_fixnum_fast(x) - untag_fixnum_fast(y));
 }
 
-CELL multiply_fixnum(CELL x, CELL y)
+CELL multiply_fixnum(CELL _x, CELL _y)
 {
-	BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
-		* (BIGNUM_2)untag_fixnum_fast(y));
+	FIXNUM x = untag_fixnum_fast(_x);
+	FIXNUM y = untag_fixnum_fast(_y);
+	long long result = (long long)x * (long long)y;
+	if(result < FIXNUM_MIN || result > FIXNUM_MAX)
+	{
+		return tag_object(s48_bignum_multiply(
+			s48_long_to_bignum(x),
+			s48_long_to_bignum(y)));
+	}
+	else
+		return tag_fixnum(result);
 }
 
 CELL divint_fixnum(CELL x, CELL y)
@@ -117,10 +126,7 @@ CELL divide_fixnum(CELL x, CELL y)
 	FIXNUM gcd;
 
 	if(_y == 0)
-	{
-		/* FIXME */
-		abort();
-	}
+		raise(SIGFPE);
 	else if(_y < 0)
 	{
 		_x = -_x;
@@ -157,14 +163,16 @@ CELL xor_fixnum(CELL x, CELL y)
 
 CELL shiftleft_fixnum(CELL x, CELL y)
 {
-	BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
-		<< (BIGNUM_2)untag_fixnum_fast(y));
+	/* BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
+		<< (BIGNUM_2)untag_fixnum_fast(y)); */
+	return F;
 }
 
 CELL shiftright_fixnum(CELL x, CELL y)
 {
-	BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
-		>> (BIGNUM_2)untag_fixnum_fast(y));
+	/* BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
+		>> (BIGNUM_2)untag_fixnum_fast(y)); */
+	return F;
 }
 
 CELL less_fixnum(CELL x, CELL y)

native/float.c

@@ -50,7 +50,7 @@ void primitive_float_to_str(void)
 void primitive_float_to_bits(void)
 {
 	double f = untag_float(dpeek());
-	BIGNUM_2 f_raw = *(BIGNUM_2*)&f;
+	long long f_raw = *(long long*)&f;
 	drepl(tag_object(s48_long_to_bignum(f_raw)));
 }
 

native/primitives.c

@@ -34,7 +34,8 @@ XT primitives[] = {
 	primitive_set_sbuf_nth,
 	primitive_sbuf_append,
 	primitive_sbuf_to_string,
-	primitive_clone_sbuf,
+	primitive_sbuf_reverse,
+	primitive_sbuf_clone,
 	primitive_sbuf_eq,
 	primitive_numberp,
 	primitive_to_fixnum,

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 141
+#define PRIMITIVE_COUNT 142
 
 CELL primitive_to_xt(CELL primitive);

native/s48_bignum.c

@@ -259,7 +259,10 @@ bignum_type
 s48_bignum_quotient(bignum_type numerator, bignum_type denominator)
 {
   if (BIGNUM_ZERO_P (denominator))
+    {
+      raise(SIGFPE);
       return (BIGNUM_OUT_OF_BAND);
+    }
   if (BIGNUM_ZERO_P (numerator))
     return (BIGNUM_MAYBE_COPY (numerator));
   {
@@ -308,7 +311,10 @@ bignum_type
 s48_bignum_remainder(bignum_type numerator, bignum_type denominator)
 {
   if (BIGNUM_ZERO_P (denominator))
+    {
+      raise(SIGFPE);
       return (BIGNUM_OUT_OF_BAND);
+    }
   if (BIGNUM_ZERO_P (numerator))
     return (BIGNUM_MAYBE_COPY (numerator));
   switch (bignum_compare_unsigned (numerator, denominator))

native/s48_bignumint.h

@@ -104,7 +104,9 @@ extern ARRAY* shrink_array(ARRAY* array, CELL capacity);
    0, 1, and -1. */
 #define BIGNUM_ZERO() bignum_zero
 #define BIGNUM_ONE(neg_p) \
-   (neg_p ? bignum_pos_one : bignum_neg_one)
+   (neg_p ? bignum_neg_one : bignum_pos_one)
+
+#define BIGNUM_ONE_P(bignum,negative_p) ((bignum) == BIGNUM_ONE(negative_p))
 
 #define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
 #define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)

native/sbuf.c

@@ -114,7 +114,22 @@ void primitive_sbuf_to_string(void)
 	drepl(tag_object(sbuf_to_string(untag_sbuf(dpeek()))));
 }
 
-void primitive_clone_sbuf(void)
+void primitive_sbuf_reverse(void)
+{
+	SBUF* sbuf = untag_sbuf(dpop());
+	int i, j;
+	CHAR ch1, ch2;
+	for(i = 0; i < sbuf->top / 2; i++)
+	{
+		j = sbuf->top - i - 1;
+		ch1 = string_nth(sbuf->string,i);
+		ch2 = string_nth(sbuf->string,j);
+		set_string_nth(sbuf->string,j,ch1);
+		set_string_nth(sbuf->string,i,ch2);
+	}
+}
+
+void primitive_sbuf_clone(void)
 {
 	SBUF* s = untag_sbuf(dpeek());
 	SBUF* new_s = sbuf(s->top);

native/sbuf.h

@@ -27,7 +27,8 @@ void sbuf_append_string(SBUF* sbuf, STRING* string);
 void primitive_sbuf_append(void);
 STRING* sbuf_to_string(SBUF* sbuf);
 void primitive_sbuf_to_string(void);
-void primitive_clone_sbuf(void);
+void primitive_sbuf_reverse(void);
+void primitive_sbuf_clone(void);
 bool sbuf_eq(SBUF* s1, SBUF* s2);
 void primitive_sbuf_eq(void);
 void fixup_sbuf(SBUF* sbuf);