Porting Scheme48 bignums to Factor.

native/array.c

@@ -1,10 +1,9 @@
 #include "factor.h"
 
 /* untagged */
-ARRAY* allot_array(CELL capacity)
+ARRAY* allot_array(CELL type, CELL capacity)
 {
-	ARRAY* array = allot_object(ARRAY_TYPE,
+	ARRAY* array = allot_object(type,sizeof(ARRAY) + capacity * CELLS);
-		sizeof(ARRAY) + capacity * CELLS);
 	array->capacity = capacity;
 	return array;
 }
@@ -14,7 +13,7 @@ ARRAY* array(CELL capacity, CELL fill)
 {
 	int i;
 
-	ARRAY* array = allot_array(capacity);
+	ARRAY* array = allot_array(ARRAY_TYPE, capacity);
 
 	for(i = 0; i < capacity; i++)
 		put(AREF(array,i),fill);
@@ -27,7 +26,7 @@ ARRAY* grow_array(ARRAY* array, CELL capacity, CELL fill)
 	/* later on, do an optimization: if end of array is here, just grow */
 	int i;
 
-	ARRAY* new_array = allot_array(capacity);
+	ARRAY* new_array = allot_array(untag_header(array->header),capacity);
 
 	memcpy(new_array + 1,array + 1,array->capacity * CELLS);
 
@@ -37,6 +36,13 @@ ARRAY* grow_array(ARRAY* array, CELL capacity, CELL fill)
 	return new_array;
 }
 
+ARRAY* shrink_array(ARRAY* array, CELL capacity)
+{
+	ARRAY* new_array = allot_array(untag_header(array->header),capacity);
+	memcpy(new_array + 1,array + 1,capacity * CELLS);
+	return new_array;
+}
+
 void fixup_array(ARRAY* array)
 {
 	int i = 0;

native/array.h

@@ -10,9 +10,10 @@ INLINE ARRAY* untag_array(CELL tagged)
 	return (ARRAY*)UNTAG(tagged);
 }
 
+ARRAY* allot_array(CELL type, CELL capacity);
 ARRAY* array(CELL capacity, CELL fill);
-
 ARRAY* grow_array(ARRAY* array, CELL capacity, CELL fill);
+ARRAY* shrink_array(ARRAY* array, CELL capacity);
 
 #define AREF(array,index) ((CELL)array + sizeof(ARRAY) + index * CELLS)
 

native/bignum.h

@@ -2,17 +2,17 @@ typedef long long BIGNUM_2;
 
 typedef struct {
 	CELL header;
-/* FIXME */
+	CELL capacity;
-#ifndef FACTOR_64
+	CELL sign;
-	CELL alignment;
+	CELL fill; /* bad */
-#endif
 	BIGNUM_2 n;
 } BIGNUM;
 
 /* untagged */
 INLINE BIGNUM* allot_bignum()
 {
-	return allot_object(BIGNUM_TYPE,sizeof(BIGNUM));
+	/* Bignums are really retrofitted arrays */
+	return (BIGNUM*)allot_array(BIGNUM_TYPE,4);
 }
 
 /* untagged */

native/complex.c

@@ -163,7 +163,7 @@ CELL divfloat_complex(CELL x, CELL y)
 }
 
 #define INCOMPARABLE(x,y) general_error(ERROR_INCOMPARABLE, \
-	tag_cons(cons(tag_complex(x),tag_complex(y))));
+	tag_cons(cons(RETAG(x,COMPLEX_TYPE),RETAG(y,COMPLEX_TYPE))));
 
 CELL less_complex(CELL x, CELL y)
 {

native/factor.h

@@ -48,6 +48,8 @@ and allows profiling. */
 #include "word.h"
 #include "run.h"
 #include "fixnum.h"
+#include "s48_bignumint.h"
+#include "s48_bignum.h"
 #include "bignum.h"
 #include "ratio.h"
 #include "float.h"

native/misc.c

@@ -42,3 +42,13 @@ void primitive_random_int(void)
 {
 	dpush(tag_object(bignum(random())));
 }
+
+void primitive_dump(void)
+{
+	/* Take an object, and print its memory. Later, return a vector */
+	CELL obj = dpop();
+	CELL size = object_size(obj);
+	int i;
+	for(i = 0; i < size; i += CELLS)
+		fprintf(stderr,"%x\n",get(UNTAG(obj) + i));
+}

native/misc.h

@@ -4,3 +4,4 @@ void primitive_eq(void);
 void primitive_millis(void);
 void primitive_init_random(void);
 void primitive_random_int(void);
+void primitive_dump(void);

native/primitives.c

@@ -140,7 +140,8 @@ XT primitives[] = {
 	primitive_size_of,
 	primitive_profiling,
 	primitive_word_call_count,
-	primitive_set_word_call_count
+	primitive_set_word_call_count,
+	primitive_dump
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

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

native/read.c

@@ -87,7 +87,7 @@ bool can_read_line(PORT* port)
 	pending_io_error(port);
 
 	if(port->type != PORT_READ && port->type != PORT_RECV)
-		general_error(ERROR_INCOMPATIBLE_PORT,port);
+		general_error(ERROR_INCOMPATIBLE_PORT,tag_object(port));
 
 	if(port->line_ready)
 		return true;
@@ -184,7 +184,7 @@ bool can_read_count(PORT* port, FIXNUM count)
 	pending_io_error(port);
 
 	if(port->type != PORT_READ && port->type != PORT_RECV)
-		general_error(ERROR_INCOMPATIBLE_PORT,port);
+		general_error(ERROR_INCOMPATIBLE_PORT,tag_object(port));
 
 	if(port->line != F && CAN_READ_COUNT(port,count))
 		return true;
@@ -237,7 +237,7 @@ void primitive_read_count_8(void)
 	PORT* port = untag_port(dpop());
 	FIXNUM len = to_fixnum(dpop());
 	if(port->count != len)
-		critical_error("read# counts don't match",port);
+		critical_error("read# counts don't match",tag_object(port));
 
 	pending_io_error(port);
 

native/relocate.c

@@ -26,6 +26,7 @@ void relocate_object()
 		break;
 	case PORT_TYPE:
 		fixup_port((PORT*)relocating);
+		break;
 	}
 
 	relocating += size;

native/s48_bignum.h

@@ -0,0 +1,94 @@
+/* -*-C-*-
+
+$Id$
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy and modify this software, to
+redistribute either the original software or a modified version, and
+to use this software for any purpose is granted, subject to the
+following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* External Interface to Bignum Code */
+
+/* The `unsigned long' type is used for the conversion procedures
+   `bignum_to_long' and `long_to_bignum'.  Older implementations of C
+   don't support this type; if you have such an implementation you can
+   disable these procedures using the following flag (alternatively
+   you could write alternate versions that don't require this type). */
+/* #define BIGNUM_NO_ULONG */
+
+typedef ARRAY * bignum_type;
+#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
+
+enum bignum_comparison
+{
+  bignum_comparison_equal = 0,
+  bignum_comparison_less = -1,
+  bignum_comparison_greater = 1
+};
+
+typedef void * bignum_procedure_context;
+extern int s48_bignum_equal_p(bignum_type, bignum_type);
+extern enum bignum_comparison s48_bignum_test(bignum_type);
+extern enum bignum_comparison s48_bignum_compare(bignum_type, bignum_type);
+extern bignum_type s48_bignum_add(bignum_type, bignum_type);
+extern bignum_type s48_bignum_subtract(bignum_type, bignum_type);
+extern bignum_type s48_bignum_negate(bignum_type);
+extern bignum_type s48_bignum_multiply(bignum_type, bignum_type);
+extern int s48_bignum_divide(bignum_type numerator, bignum_type denominator,
+			     void * quotient, void * remainder);
+extern bignum_type s48_bignum_quotient(bignum_type, bignum_type);
+extern bignum_type s48_bignum_remainder(bignum_type, bignum_type);
+extern bignum_type s48_long_to_bignum(long);
+extern bignum_type s48_ulong_to_bignum(unsigned long);
+extern long s48_bignum_to_long(bignum_type);
+extern unsigned long s48_bignum_to_ulong(bignum_type);
+extern bignum_type s48_double_to_bignum(double);
+extern double s48_bignum_to_double(bignum_type);
+extern int s48_bignum_fits_in_word_p(bignum_type, long word_length,
+				     int twos_complement_p);
+extern bignum_type s48_bignum_length_in_bits(bignum_type);
+extern bignum_type s48_bignum_length_upper_limit(void);
+extern bignum_type s48_digit_stream_to_bignum
+       (unsigned int n_digits,
+	unsigned int (*producer(bignum_procedure_context)),
+	bignum_procedure_context context,
+	unsigned int radix,
+	int negative_p);
+extern long s48_bignum_max_digit_stream_radix(void);
+
+/* Added bitwise operators. */
+
+extern bignum_type s48_bignum_bitwise_not(bignum_type),
+                   s48_bignum_arithmetic_shift(bignum_type, long),
+                   s48_bignum_bitwise_and(bignum_type, bignum_type),
+                   s48_bignum_bitwise_ior(bignum_type, bignum_type),
+                   s48_bignum_bitwise_xor(bignum_type, bignum_type);
+
+extern int s48_bignum_oddp(bignum_type);
+extern long s48_bignum_bit_count(bignum_type);

native/s48_bignumint.h

@@ -0,0 +1,127 @@
+/* -*-C-*-
+
+$Id$
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy and modify this software, to
+redistribute either the original software or a modified version, and
+to use this software for any purpose is granted, subject to the
+following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Internal Interface to Bignum Code */
+#undef BIGNUM_ZERO_P
+#undef BIGNUM_NEGATIVE_P
+
+/* The memory model is based on the following definitions, and on the
+   definition of the type `bignum_type'.  The only other special
+   definition is `CHAR_BIT', which is defined in the Ansi C header
+   file "limits.h". */
+
+typedef CELL bignum_digit_type;
+typedef CELL bignum_length_type;
+
+/* BIGNUM_ALLOCATE allocates a (length + 1)-element array of
+   `bignum_digit_type'; deallocation is the responsibility of the
+   user (in Factor, the garbage collector handles this). */
+#define BIGNUM_ALLOCATE(length_in_digits) \
+	allot_array(BIGNUM_TYPE,length_in_digits + 1)
+
+/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
+#define BIGNUM_TO_POINTER(bignum) ((CELL*)AREF(bignum,0))
+
+/* BIGNUM_REDUCE_LENGTH allows the memory system to reclaim some
+   space when a bignum's length is reduced from its original value. */
+#define BIGNUM_REDUCE_LENGTH(target, source, length)            \
+     target = shrink_array(source, length)
+extern ARRAY* shrink_array(ARRAY* array, CELL capacity);
+
+/* BIGNUM_DEALLOCATE is called when disposing of bignums which are
+   created as intermediate temporaries; Scheme doesn't need this. */
+#define BIGNUM_DEALLOCATE(bignum)
+
+/* If BIGNUM_FORCE_NEW_RESULTS is defined, all bignum-valued operations
+   return freshly-allocated results.  This is useful for some kinds of
+   memory deallocation strategies. */
+/* #define BIGNUM_FORCE_NEW_RESULTS */
+
+/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
+#define BIGNUM_EXCEPTION abort
+
+
+#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
+#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
+#define BIGNUM_RADIX (((unsigned long) 1) << BIGNUM_DIGIT_LENGTH)
+#define BIGNUM_RADIX_ROOT (((unsigned long) 1) << BIGNUM_HALF_DIGIT_LENGTH)
+#define BIGNUM_DIGIT_MASK	 (BIGNUM_RADIX - 1)
+#define BIGNUM_HALF_DIGIT_MASK	 (BIGNUM_RADIX_ROOT - 1)
+
+#define BIGNUM_START_PTR(bignum)					\
+  ((BIGNUM_TO_POINTER (bignum)) + 1)
+
+#define BIGNUM_LENGTH(bignum) (bignum->capacity - 1)
+
+#define BIGNUM_NEGATIVE_P(bignum) (AREF(bignum,0) != 0)
+#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
+
+#define BIGNUM_ZERO_P(bignum)						\
+  ((BIGNUM_LENGTH (bignum)) == 0)
+
+#define BIGNUM_REF(bignum, index)					\
+  (* ((BIGNUM_START_PTR (bignum)) + (index)))
+
+#ifdef BIGNUM_FORCE_NEW_RESULTS
+#define BIGNUM_MAYBE_COPY bignum_copy
+#else
+#define BIGNUM_MAYBE_COPY(bignum) bignum
+#endif
+
+/* These definitions are here to facilitate caching of the constants
+   0, 1, and -1. */
+#define BIGNUM_ZERO() s48_bignum_zero
+#define BIGNUM_ONE(neg_p) \
+   (neg_p ? s48_bignum_pos_one : s48_bignum_neg_one)
+
+#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
+#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
+#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
+
+#define BIGNUM_BITS_TO_DIGITS(n)					\
+  (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
+
+#define BIGNUM_DIGITS_FOR_LONG						\
+  (BIGNUM_BITS_TO_DIGITS ((sizeof (long)) * CHAR_BIT))
+
+#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
+
+#define BIGNUM_ASSERT(expression)					\
+{									\
+  if (! (expression))							\
+    BIGNUM_EXCEPTION ();						\
+}
+
+#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */

native/types.c

@@ -77,6 +77,7 @@ CELL untagged_object_size(CELL pointer)
 		size = CELLS * 2;
 		break;
 	case ARRAY_TYPE:
+	case BIGNUM_TYPE:
 		size = ASIZE(pointer);
 		break;
 	case VECTOR_TYPE:
@@ -88,9 +89,6 @@ CELL untagged_object_size(CELL pointer)
 	case SBUF_TYPE:
 		size = sizeof(SBUF);
 		break;
-	case BIGNUM_TYPE:
-		size = sizeof(BIGNUM);
-		break;
 	case FLOAT_TYPE:
 		size = sizeof(FLOAT);
 		break;