~ chicken-core (chicken-5) ed374ee144fbbb6665954913a0837348bd693fcf
commit ed374ee144fbbb6665954913a0837348bd693fcf
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Feb 1 21:21:37 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:17:21 2015 +0200
Add bignum support to the FFI.
diff --git a/c-backend.scm b/c-backend.scm
index 9440c848..ab4d2a25 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1101,11 +1101,14 @@
((char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
byte unsigned-byte)
ns)
- ((float double c-pointer unsigned-integer unsigned-integer32 long integer integer32
- unsigned-long size_t
- nonnull-c-pointer number unsigned-integer64 integer64 c-string-list
- c-string-list*)
+ ((float double c-pointer nonnull-c-pointer
+ c-string-list c-string-list*)
(string-append ns "+3") )
+ ((unsigned-integer unsigned-integer32 long integer integer32
+ unsigned-long size_t number)
+ (string-append ns "+C_SIZEOF_FIX_BIGNUM"))
+ ((unsigned-integer64 integer64) ; On 32-bit systems, needs 2 digits
+ (string-append ns "+C_SIZEOF_BIGNUM(2)"))
((c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
(string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") )
((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
@@ -1351,8 +1354,9 @@
(sprintf "C_mpointer(&~a,(void*)" dest) )
((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))
((integer integer32) (sprintf "C_int_to_num(&~a," dest))
- ((integer64 unsigned-integer64) (sprintf "C_a_double_to_num(&~a," dest))
- ((size_t) (sprintf "C_int_to_num(&~a,(int)" dest))
+ ((integer64) (sprintf "C_int64_to_num(&~a," dest))
+ ((size_t) (sprintf "C_int_to_num(&~a,(int)" dest)) ; XXX 64 bits?
+ ((unsigned-integer64) (sprintf "C_uint64_to_num(&~a," dest))
((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))
((long) (sprintf "C_long_to_num(&~a," dest))
((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))
diff --git a/chicken.h b/chicken.h
index 2fac5074..52a4805f 100644
--- a/chicken.h
+++ b/chicken.h
@@ -687,6 +687,7 @@ static inline int isinf_ld (long double x)
#define C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR 50
#define C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR 51
#define C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR 52
+#define C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION 53
/* Platform information */
#if defined(C_BIG_ENDIAN)
@@ -2264,6 +2265,45 @@ C_inline C_word C_double_to_number(C_word n)
else return n;
}
+/* Silly (this is not normalized) but in some cases needed internally */
+C_inline C_word C_bignum0(C_word **ptr)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ /* Not using C_a_i_vector4, to make it easier to rewrite later */
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(1);
+ *(p++) = 0; /* zero is always positive */
+ *ptr = p;
+
+ return p0;
+}
+
+C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(2);
+ *(p++) = negp;
+ *(p++) = d1;
+ *ptr = p;
+
+ return p0;
+}
+
+/* Here d1, d2, ... are low to high (ie, little endian)! */
+C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
+{
+ C_word *p = *ptr, p0 = (C_word)p;
+
+ *(p++) = C_BIGNUM_TYPE | C_wordstobytes(3);
+ *(p++) = negp;
+ *(p++) = d1;
+ *(p++) = d2;
+ *ptr = p;
+
+ return p0;
+}
+
C_inline C_word C_fits_in_int_p(C_word x)
{
@@ -2271,6 +2311,13 @@ C_inline C_word C_fits_in_int_p(C_word x)
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+ if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_mk_bool(C_bignum_size(x) == 1 &&
+ (!C_bignum_negativep(x) ||
+ !(C_bignum_digits(x)[0] & C_INT_SIGN_BIT)));
+ }
+
+ /* XXX OBSOLETE remove on the next round, remove check above */
n = C_flonum_magnitude(x);
return C_mk_bool(C_modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
}
@@ -2282,6 +2329,11 @@ C_inline C_word C_fits_in_unsigned_int_p(C_word x)
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+ if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_mk_bool(C_bignum_size(x) == 1);
+ }
+
+ /* XXX OBSOLETE remove on the next round, remove check above */
n = C_flonum_magnitude(x);
return C_mk_bool(C_modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
}
@@ -2296,73 +2348,117 @@ C_inline double C_c_double(C_word x)
C_inline C_word C_num_to_int(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (int)C_flonum_magnitude(x);
+ if(x & C_FIXNUM_BIT) {
+ return C_unfix(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ if (C_bignum_negativep(x)) return -(C_word)C_bignum_digits(x)[0];
+ else return (C_word)C_bignum_digits(x)[0]; /* should never be larger */
+ } else {
+ /* XXX OBSOLETE remove on the next round, remove check above */
+ return (C_word)C_flonum_magnitude(x);
+ }
}
C_inline C_s64 C_num_to_int64(C_word x)
{
- if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
- else return (C_s64)C_flonum_magnitude(x);
+ if(x & C_FIXNUM_BIT) {
+ return (C_s64)C_unfix(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ C_s64 num = C_bignum_digits(x)[0];
+#ifndef C_SIXTY_FOUR
+ if (C_bignum_size(x) > 1) num |= ((C_s64)C_bignum_digits(x)[1]) << 32;
+#endif
+ if (C_bignum_negativep(x)) return -num;
+ else return num;
+ } else {
+ /* XXX OBSOLETE remove on the next round, remove check above */
+ return (C_s64)C_flonum_magnitude(x);
+ }
}
C_inline C_u64 C_num_to_uint64(C_word x)
{
- if(x & C_FIXNUM_BIT) return (C_u64)C_unfix(x);
- else return (C_u64)C_flonum_magnitude(x);
+ if(x & C_FIXNUM_BIT) {
+ return (C_u64)C_unfix(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ C_u64 num = C_bignum_digits(x)[0];
+#ifndef C_SIXTY_FOUR
+ if (C_bignum_size(x) > 1) num |= ((C_u64)C_bignum_digits(x)[1]) << 32;
+#endif
+ return num;
+ } else {
+ /* XXX OBSOLETE remove on the next round, remove check above */
+ return (C_u64)C_flonum_magnitude(x);
+ }
}
C_inline C_uword C_num_to_unsigned_int(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (unsigned int)C_flonum_magnitude(x);
+ if(x & C_FIXNUM_BIT) {
+ return (C_uword)C_unfix(x);
+ } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ return C_bignum_digits(x)[0]; /* should never be larger */
+ } else {
+ /* XXX OBSOLETE remove on the next round, remove check above */
+ return (C_uword)C_flonum_magnitude(x);
+ }
}
C_inline C_word C_int_to_num(C_word **ptr, C_word n)
{
if(C_fitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
+ else return C_bignum1(ptr, n < 0, labs(n));
}
C_inline C_word C_unsigned_int_to_num(C_word **ptr, C_uword n)
{
if(C_ufitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
+ else return C_bignum1(ptr, 0, n);
}
-
-C_inline C_word C_long_to_num(C_word **ptr, C_long n)
+C_inline C_word C_int64_to_num(C_word **ptr, C_s64 n)
{
- if(C_fitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
+ if(C_fitsinfixnump(n)) {
+ return C_fix(n);
+ } else {
+ C_u64 un = n < 0 ? -n : n;
+#ifdef C_SIXTY_FOUR
+ return C_bignum1(ptr, n < 0, un);
+#else
+ C_word res = C_bignum2(ptr, n < 0, (C_uword)un, (C_uword)(un >> 32));
+ return C_bignum_simplify(res);
+#endif
+ }
}
-
-C_inline C_word C_unsigned_long_to_num(C_word **ptr, C_ulong n)
+C_inline C_word C_uint64_to_num(C_word **ptr, C_u64 n)
{
- if(C_ufitsinfixnump(n)) return C_fix(n);
- else return C_flonum(ptr, (double)n);
+ if(C_ufitsinfixnump(n)) {
+ return C_fix(n);
+ } else {
+#ifdef C_SIXTY_FOUR
+ return C_bignum1(ptr, 0, n);
+#else
+ C_word res = C_bignum2(ptr, 0, (C_uword)n, (C_uword)(n >> 32));
+ return C_bignum_simplify(res);
+#endif
+ }
}
-
-C_inline C_word C_flonum_in_int_range_p(C_word n)
+C_inline C_word C_long_to_num(C_word **ptr, C_long n)
{
- double m = C_flonum_magnitude(n);
-
- return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
+ return C_int64_to_num(ptr, (C_s64)n);
}
-C_inline C_word C_flonum_in_uint_range_p(C_word n)
+C_inline C_word C_unsigned_long_to_num(C_word **ptr, C_ulong n)
{
- double m = C_flonum_magnitude(n);
-
- return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
+ return C_uint64_to_num(ptr, (C_u64)n);
}
@@ -2647,45 +2743,6 @@ C_inline C_word C_i_ratnump(C_word x)
C_block_item(x, 0) == C_ratnum_type_tag);
}
-/* Silly (this is not normalized) but in some cases needed internally */
-C_inline C_word C_bignum0(C_word **ptr)
-{
- C_word *p = *ptr, p0 = (C_word)p;
-
- /* Not using C_a_i_vector4, to make it easier to rewrite later */
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(1);
- *(p++) = 0; /* zero is always positive */
- *ptr = p;
-
- return p0;
-}
-
-C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
-{
- C_word *p = *ptr, p0 = (C_word)p;
-
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(2);
- *(p++) = negp;
- *(p++) = d1;
- *ptr = p;
-
- return p0;
-}
-
-/* Here d1, d2, ... are low to high (ie, little endian)! */
-C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
-{
- C_word *p = *ptr, p0 = (C_word)p;
-
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(3);
- *(p++) = negp;
- *(p++) = d1;
- *(p++) = d2;
- *ptr = p;
-
- return p0;
-}
-
/* TODO: Is this correctly named? Shouldn't it accept an argcount? */
C_inline C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
{
@@ -2792,8 +2849,6 @@ C_inline C_word C_a_i_fixnum_difference(C_word **ptr, C_word n, C_word x, C_word
C_word z = C_unfix(x) - C_unfix(y);
if(!C_fitsinfixnump(z)) {
- /* TODO: function/macro returning either fixnum or bignum from a C int */
- /* This should help with the C API/FFI too. */
return C_bignum1(ptr, z < 0, labs(z));
} else {
return C_fix(z);
@@ -2809,8 +2864,6 @@ C_inline C_word C_a_i_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y)
C_word z = C_unfix(x) + C_unfix(y);
if(!C_fitsinfixnump(z)) {
- /* TODO: function/macro returning either fixnum or bignum from a C int */
- /* This should help with the C API/FFI too. */
return C_bignum1(ptr, z < 0, labs(z));
} else {
return C_fix(z);
diff --git a/library.scm b/library.scm
index 72f9ce57..ca3d07da 100644
--- a/library.scm
+++ b/library.scm
@@ -5442,6 +5442,7 @@ EOF
((50) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a real" args))
((51) (apply ##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" args))
((52) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact integer" args))
+ ((53) (apply ##sys#signal-hook #:type-error loc "number does not fit in foreign type" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
diff --git a/runtime.c b/runtime.c
index 8639cf62..9a38d6e5 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1856,6 +1856,11 @@ void barf(int code, char *loc, ...)
c = 1;
break;
+ case C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION:
+ msg = C_text("number does not fit in foreign type");
+ c = 1;
+ break;
+
default: panic(C_text("illegal internal error code"));
}
@@ -6663,6 +6668,12 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
if((x & C_FIXNUM_BIT) != 0) return x;
+ if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+ if (C_bignum_size(x) == 1) return x;
+ else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
+ }
+
+ /* XXX OBSOLETE: This should be removed on the next round */
if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
m = C_flonum_magnitude(x);
@@ -6680,6 +6691,16 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
if((x & C_FIXNUM_BIT) != 0) return x;
+ if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+#ifdef C_SIXTY_FOUR
+ if (C_bignum_size(x) == 1) return x;
+#else
+ if (C_bignum_size(x) <= 2) return x;
+#endif
+ else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
+ }
+
+ /* XXX OBSOLETE: This should be removed on the next round */
if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
m = C_flonum_magnitude(x);
diff --git a/support.scm b/support.scm
index d6fcf95d..452010ae 100644
--- a/support.scm
+++ b/support.scm
@@ -1124,9 +1124,12 @@
c-string-list c-string-list*)
(words->bytes 3) )
((unsigned-integer long integer size_t unsigned-long integer32 unsigned-integer32)
- (words->bytes 4) )
- ((float double number integer64 unsigned-integer64)
+ ;; OBSOLETE: replace 4 with 3 after bootstrap completed
+ (words->bytes #;3 4) ) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
+ ((float double number)
(words->bytes 4) ) ; possibly 8-byte aligned 64-bit double
+ ((integer64 unsigned-integer64)
+ (words->bytes 4)) ; 2 bignum digits on 32-bit (overallocs on 64-bit)
(else
(cond ((and (symbol? t) (lookup-foreign-type t))
=> (lambda (t2) (next (vector-ref t2 0)) ) )
@@ -1151,6 +1154,7 @@
unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string* size_t
nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*)
(words->bytes 1) )
+ ;; XXX TODO FIXME: What is "number" doing here?
((double number integer64 unsigned-integer64)
(words->bytes 2) )
(else
@@ -1241,7 +1245,7 @@
((nonnull-f64vector) '(struct f64vector))
((integer long size_t integer32 unsigned-integer32 integer64 unsigned-integer64
unsigned-long)
- 'number)
+ 'integer)
((c-pointer)
'(or boolean pointer locative))
((nonnull-c-pointer) 'pointer)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 87b472fb..8af17237 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -258,11 +258,10 @@
(string->number "179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0")))
;; #955: unsigned-integer64 arg returned magnitude instead of Scheme object.
-#+64bit
-(assert (= #xAB54A98CEB1F0AD2
- ((foreign-lambda* unsigned-integer64 ((unsigned-integer64 x))
- "C_return(x);")
- #xAB54A98CEB1F0AD2)))
+(assert (eqv? #xAB54A98CEB1F0AD2
+ ((foreign-lambda* unsigned-integer64 ((unsigned-integer64 x))
+ "C_return(x);")
+ #xAB54A98CEB1F0AD2)))
;; #1059: foreign vector types use wrong lolevel accessors, causing
;; paranoid DEBUGBUILD assertions to fail.
Trap