~ chicken-core (chicken-5) 7e9044a83095f26824190e851b60360764183625
commit 7e9044a83095f26824190e851b60360764183625
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue Jun 6 21:28:21 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Jun 8 11:32:12 2017 +1200
Fix size_t to map to unsigned 64-bit integers, add signed ssize_t
Add a test case to ensure they can represent the proper range.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index d179db00..f4b0e041 100644
--- a/NEWS
+++ b/NEWS
@@ -82,6 +82,11 @@
- Static compilation of eggs is now fully supported and static
versions of compiled eggs are available by default.
+- Foreign function interface
+ - The foreign type specifier "ssize_t" is now accepted, and "size_t"
+ arguments now only accept positive integers. Return values of
+ type size_t are no longer truncated on 32-bit platforms.
+
4.12.1
diff --git a/c-backend.scm b/c-backend.scm
index 1c0f8f2f..6be88abe 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1129,9 +1129,10 @@
c-string-list c-string-list*)
(string-append ns "+3") )
((unsigned-integer unsigned-integer32 long integer integer32
- unsigned-long size_t number)
+ unsigned-long number)
(string-append ns "+C_SIZEOF_FIX_BIGNUM"))
- ((unsigned-integer64 integer64) ; On 32-bit systems, needs 2 digits
+ ((unsigned-integer64 integer64 size_t ssize_t)
+ ;; 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 ")))") )
@@ -1203,6 +1204,7 @@
((unsigned-int32 unsigned-integer32) (str "C_u32"))
((int integer bool) (str "int"))
((size_t) (str "size_t"))
+ ((ssize_t) (str "ssize_t"))
((int32 integer32) (str "C_s32"))
((integer64) (str "C_s64"))
((unsigned-integer64) (str "C_u64"))
@@ -1303,7 +1305,8 @@
((double number float) "C_c_double(")
((integer integer32) "C_num_to_int(")
((integer64) "C_num_to_int64(")
- ((size_t) "(size_t)C_num_to_int(")
+ ((size_t) "(size_t)C_num_to_uint64(")
+ ((ssize_t) "(ssize_t)C_num_to_int64(")
((unsigned-integer64) "C_num_to_uint64(")
((long) "C_num_to_long(")
((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")
@@ -1384,9 +1387,8 @@
(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) (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))
+ ((integer64 ssize_t) (sprintf "C_int64_to_num(&~a," dest))
+ ((unsigned-integer64 size_t) (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/support.scm b/support.scm
index 2c04d2e0..233ad961 100644
--- a/support.scm
+++ b/support.scm
@@ -975,7 +975,7 @@
(integer64 . "C_s64") (unsigned-integer64 . "C_u64")
(short . "short") (unsigned-short . "unsigned short")
(long . "long") (unsigned-long . "unsigned long")
- (size_t . "size_t"))))
+ (ssize_t . "ssize_t") (size_t . "size_t"))))
(lambda (param type)
(follow-without-loop
type
@@ -1030,14 +1030,14 @@
`(##sys#foreign-struct-wrapper-argument
',(##sys#slot (assq t tmap) 1)
,param) ) )
- ((integer32 integer64 integer short long size_t)
+ ((integer32 integer64 integer short long ssize_t)
(let* ((foreign-type (##sys#slot (assq t ftmap) 1))
(size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
(if unsafe
param
`(##sys#foreign-ranged-integer-argument
,param (foreign-value ,size-expr int)))))
- ((unsigned-short unsigned-long unsigned-integer
+ ((unsigned-short unsigned-long unsigned-integer size_t
unsigned-integer32 unsigned-integer64)
(let* ((foreign-type (##sys#slot (assq t ftmap) 1))
(size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
@@ -1155,11 +1155,11 @@
unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
c-string-list c-string-list*)
(words->bytes 3) )
- ((unsigned-integer long integer size_t unsigned-long integer32 unsigned-integer32)
+ ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
(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)
+ ((integer64 unsigned-integer64 size_t ssize_t)
(words->bytes 7)) ; 2 bignum digits on 32-bit (overallocs on 64-bit)
(else
(cond ((and (symbol? t) (lookup-foreign-type t))
@@ -1182,11 +1182,10 @@
((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
c-pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
- unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string* size_t
+ unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
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)
+ ((double integer64 unsigned-integer64 size_t ssize_t)
(words->bytes 2) )
(else
(cond ((and (symbol? t) (lookup-foreign-type t))
@@ -1276,7 +1275,7 @@
((nonnull-s64vector) '(struct s64vector))
((nonnull-f32vector) '(struct f32vector))
((nonnull-f64vector) '(struct f64vector))
- ((integer long size_t integer32 unsigned-integer32 integer64 unsigned-integer64
+ ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64
unsigned-long)
'integer)
((c-pointer)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 9d92afc6..d753beea 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -357,6 +357,12 @@
(test-ffi-type-limits
long signed (foreign-value "sizeof(long) * CHAR_BIT" int))
+(test-ffi-type-limits
+ ssize_t signed (foreign-value "sizeof(ssize_t) * CHAR_BIT" int))
+
+(test-ffi-type-limits
+ size_t unsigned (foreign-value "sizeof(size_t) * CHAR_BIT" int))
+
;; #1059: foreign vector types use wrong lolevel accessors, causing
;; paranoid DEBUGBUILD assertions to fail.
Trap