~ chicken-core (chicken-5) 81da7430a61c9c2a00c2a783d21aee61d1be39a3
commit 81da7430a61c9c2a00c2a783d21aee61d1be39a3
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri May 22 21:24:23 2015 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:55:25 2015 +0200
Also add handling for bignums to [unsigned-]long and fix integer64 and integer argument type checkers to accept bignums too. Add a few basic tests. Fix size calculation for foreign [unsigned]-integer64 type and srfi-4 conversions and fix conversion on 32-bit platforms.
diff --git a/chicken.h b/chicken.h
index 12d32c4a..94363b00 100644
--- a/chicken.h
+++ b/chicken.h
@@ -2613,17 +2613,18 @@ C_inline C_word C_unsigned_int_to_num(C_word **ptr, C_uword n)
C_inline C_word C_int64_to_num(C_word **ptr, C_s64 n)
{
+#ifdef C_SIXTY_FOUR
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);
+ C_u64 un = n < 0 ? -n : n;
+ 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_uint64_to_num(C_word **ptr, C_u64 n)
@@ -2690,15 +2691,28 @@ C_inline void *C_scheme_or_c_pointer(C_word x)
C_inline C_long C_num_to_long(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (C_long)C_flonum_magnitude(x);
+ if(x & C_FIXNUM_BIT) {
+ return (C_long)C_unfix(x);
+ } else if (C_truep(C_bignump(x))) {
+ if (C_bignum_negativep(x)) return -(C_long)C_bignum_digits(x)[0];
+ else return (C_long)C_bignum_digits(x)[0];
+ } else {
+ /* XXX OBSOLETE remove on the next round, remove check above */
+ return (C_long)C_flonum_magnitude(x);
+ }
}
C_inline C_ulong C_num_to_unsigned_long(C_word x)
{
- if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (C_ulong)C_flonum_magnitude(x);
+ if(x & C_FIXNUM_BIT) {
+ return (C_ulong)C_unfix(x);
+ } else if (C_truep(C_bignump(x))) {
+ return (C_ulong)C_bignum_digits(x)[0];
+ } else {
+ /* XXX OBSOLETE remove on the next round, remove check above */
+ return (C_ulong)C_flonum_magnitude(x);
+ }
}
diff --git a/manual/C interface b/manual/C interface
index 2d8f2675..8a0c44af 100644
--- a/manual/C interface
+++ b/manual/C interface
@@ -599,7 +599,7 @@ of a given type.
==== C_num_to_int
- [C function] int C_num_to_int (C_word fixnum_or_flonum)
+ [C function] int C_num_to_int (C_word fixnum_or_bignum)
==== C_pointer_address
diff --git a/runtime.c b/runtime.c
index 99fe2034..717f2d58 100644
--- a/runtime.c
+++ b/runtime.c
@@ -6938,6 +6938,12 @@ C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
if((x & C_FIXNUM_BIT) != 0) return x;
+ if(C_truep(C_i_bignump(x))) {
+ 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);
@@ -6955,6 +6961,16 @@ C_regparm C_word C_fcall C_i_foreign_integer64_argumentp(C_word x)
if((x & C_FIXNUM_BIT) != 0) return x;
+ if(C_truep(C_i_bignump(x))) {
+#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/srfi-4.scm b/srfi-4.scm
index 50d05d92..8a999144 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -550,10 +550,10 @@ EOF
(NNNvector->list u16vector)
(NNNvector->list s16vector)
;; The alloc amounts here are for 32-bit words; this over-allocates on 64-bits
-(NNNvector->list u32vector 2)
-(NNNvector->list s32vector 2)
-(NNNvector->list u64vector 3)
-(NNNvector->list s64vector 3)
+(NNNvector->list u32vector 6)
+(NNNvector->list s32vector 6)
+(NNNvector->list u64vector 7)
+(NNNvector->list s64vector 7)
(NNNvector->list f32vector 4)
(NNNvector->list f64vector 4)
diff --git a/support.scm b/support.scm
index b0665584..4cd67379 100644
--- a/support.scm
+++ b/support.scm
@@ -1129,12 +1129,11 @@
c-string-list c-string-list*)
(words->bytes 3) )
((unsigned-integer long integer size_t unsigned-long integer32 unsigned-integer32)
- ;; OBSOLETE: replace 4 with 3 after bootstrap completed
- (words->bytes #;3 4) ) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
+ (words->bytes 6) ) ; 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)
+ (words->bytes 7)) ; 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)) ) )
@@ -1763,4 +1762,4 @@ Available debugging options:
EOF
))
-)
\ No newline at end of file
+)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 6021bcfa..f79fda54 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -263,6 +263,85 @@
"C_return(x);")
#xAB54A98CEB1F0AD2)))
+
+;; Test the maximum and minimum values of the FFI's integer types
+(define-syntax test-ffi-type-limits
+ (syntax-rules (signed unsigned)
+ ((_ ?type-name unsigned ?bits)
+ (let ((limit (arithmetic-shift 1 ?bits)))
+ (print "Testing unsigned FFI type \"" '?type-name "\" (" ?bits " bits):")
+ (print "Can hold maximum value " (sub1 limit) "...")
+ (assert
+ (eqv? (sub1 limit)
+ ((foreign-lambda* ?type-name ((?type-name x))
+ "C_return(x);") (sub1 limit))))
+ ;; TODO: Should we test for these?
+ #;(print "Cannot hold one more than maximum value, " limit "...")
+ #;(assert
+ (handle-exceptions exn #t
+ (begin ((foreign-lambda* ?type-name ((?type-name x))
+ "C_return(x);") limit)
+ #f)))
+ #;(print "Cannot hold -1 (any fixnum negative value)")
+ #;(assert
+ (handle-exceptions exn #t
+ (begin ((foreign-lambda* ?type-name ((?type-name x))
+ "C_return(x);") -1)
+ #f)))
+ (print "Cannot hold -2^64 (any bignum negative value < smallest int64)")
+ (assert
+ (handle-exceptions exn #t
+ (begin ((foreign-lambda* ?type-name ((?type-name x))
+ "C_return(x);") #x-10000000000000000)
+ #f)))))
+ ((_ ?type-name signed ?bits)
+ (let ((limit (arithmetic-shift 1 (sub1 ?bits))))
+ (print "Testing signed FFI type \"" '?type-name "\" (" ?bits " bits):")
+ (print "Can hold maximum value " (sub1 limit) "...")
+ (assert
+ (eqv? (sub1 limit)
+ ((foreign-lambda* ?type-name ((?type-name x))
+ "C_return(x);") (sub1 limit))))
+ (print "Can hold minimum value " (- limit) "...")
+ (assert
+ (eqv? (- limit)
+ ((foreign-lambda* ?type-name ((?type-name x))
+ "C_return(x);") (- limit))))
+ ;; TODO: Should we check for these?
+ #;(print "Cannot hold one more than maximum value " limit "...")
+ #;(assert
+ (handle-exceptions exn #t
+ (begin ((foreign-lambda* integer ((integer x))
+ "C_return(x);") limit)
+ #f)))
+ #;(print "Cannot hold one less than minimum value " (- limit) "...")
+ #;(assert
+ (handle-exceptions exn #t
+ (begin ((foreign-lambda* integer ((integer x))
+ "C_return(x);") (sub1 (- limit)))
+ #f)))))))
+
+(test-ffi-type-limits unsigned-integer32 unsigned 32)
+(test-ffi-type-limits integer32 signed 32)
+
+(test-ffi-type-limits unsigned-integer64 unsigned 64)
+(test-ffi-type-limits integer64 signed 64)
+
+(test-ffi-type-limits
+ unsigned-integer unsigned
+ (foreign-value "sizeof(unsigned int) * CHAR_BIT" int))
+
+(test-ffi-type-limits
+ integer signed (foreign-value "sizeof(int) * CHAR_BIT" int))
+
+(test-ffi-type-limits
+ unsigned-long unsigned
+ (foreign-value "sizeof(unsigned long) * CHAR_BIT" int))
+
+(test-ffi-type-limits
+ long signed (foreign-value "sizeof(long) * CHAR_BIT" int))
+
+
;; #1059: foreign vector types use wrong lolevel accessors, causing
;; paranoid DEBUGBUILD assertions to fail.
(define-syntax srfi-4-vector-length
Trap