From 13d4cadd0fe5380b05b93faef4ec5071e7a5cf04 Mon Sep 17 00:00:00 2001 From: Chris Payne Date: Fri, 29 Sep 2023 16:57:47 -0400 Subject: [PATCH 1/7] fix typo in documentation --- csug/foreign.stex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/csug/foreign.stex b/csug/foreign.stex index e42c4329f..7ec6f8d34 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -3134,7 +3134,7 @@ appear negative if cast to integers. whereas \scheme{Sunsigned} converts such values into the appropriate positive Scheme values. For example, assuming a 32-bit, two's complement representation for -\scheme{iptrs}, \scheme{Sinteger(-1)} and \scheme{Sunsigned((iptr)0xffffffff)} +\scheme{iptrs}, \scheme{Sinteger(-1)} and \scheme{Sinteger((iptr)0xffffffff)} both evaluate to the Scheme integer \scheme{-1}, whereas \scheme{Sunsigned(0xffffffff)} and \scheme{Sunsigned((uptr)-1)} both evaluate to the Scheme integer From 4e0cd60829ed450e2a83d25d87c827cbf7132e6b Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Fri, 29 Sep 2023 10:30:10 -0400 Subject: [PATCH 2/7] add types for cross-platform downstream code This commit adds types such as Sint32_t and Suint64_t that downstream code can use reliably with foreign integer conversion entry points such as Sinteger32 and Sunsigned64. CSUG now documents these functions using the new types instead of "<32-bit int type>", "<64-bit unsigned type>", etc. --- LOG | 4 ++++ boot/a6le/scheme.h | 22 ++++++++++++++-------- boot/a6nt/scheme.h | 22 ++++++++++++++-------- boot/a6osx/scheme.h | 22 ++++++++++++++-------- boot/arm32le/scheme.h | 22 ++++++++++++++-------- boot/i3le/scheme.h | 22 ++++++++++++++-------- boot/i3nt/scheme.h | 22 ++++++++++++++-------- boot/i3osx/scheme.h | 22 ++++++++++++++-------- boot/ta6le/scheme.h | 22 ++++++++++++++-------- boot/ta6nt/scheme.h | 22 ++++++++++++++-------- boot/ta6osx/scheme.h | 22 ++++++++++++++-------- boot/ti3le/scheme.h | 22 ++++++++++++++-------- boot/ti3nt/scheme.h | 22 ++++++++++++++-------- boot/ti3osx/scheme.h | 22 ++++++++++++++-------- c/number.c | 10 +++++----- csug/foreign.stex | 16 ++++++++-------- release_notes/release_notes.stex | 7 +++++++ s/mkheader.ss | 23 +++++++++++++++-------- 18 files changed, 221 insertions(+), 125 deletions(-) diff --git a/LOG b/LOG index 4d8646a0c..90c976bff 100644 --- a/LOG +++ b/LOG @@ -2441,3 +2441,7 @@ wininstall/ta6nt.wxs wininstall/ti3nt.wxs - fix (library ) import syntax mats/8.ms release_notes/release_notes.stex s/syntax.ss +- add Sint32_t, Suint32_t, Sint64_t, Suint64_t types for cross-platform + code that uses scheme.h exports + boot/*/scheme.h c/number.c csug/foreign.stex + release_notes/release_notes.stex s/mkheader.ss diff --git a/boot/a6le/scheme.h b/boot/a6le/scheme.h index 4ed47ea1e..fe91fc4f3 100644 --- a/boot/a6le/scheme.h +++ b/boot/a6le/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef long int iptr; typedef unsigned long int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long Sint64_t; +typedef unsigned long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+9))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long); -EXPORT ptr Sunsigned64(unsigned long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/a6nt/scheme.h b/boot/a6nt/scheme.h index 4163bebe8..3dffd074f 100644 --- a/boot/a6nt/scheme.h +++ b/boot/a6nt/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef long long int iptr; typedef unsigned long long int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+9))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/a6osx/scheme.h b/boot/a6osx/scheme.h index b4ad7c513..ea1b2fa5c 100644 --- a/boot/a6osx/scheme.h +++ b/boot/a6osx/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef long int iptr; typedef unsigned long int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long Sint64_t; +typedef unsigned long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+9))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long); -EXPORT ptr Sunsigned64(unsigned long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/arm32le/scheme.h b/boot/arm32le/scheme.h index 4d294c1c2..6fb06c2ab 100644 --- a/boot/arm32le/scheme.h +++ b/boot/arm32le/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/i3le/scheme.h b/boot/i3le/scheme.h index 31af78481..43cb78f71 100644 --- a/boot/i3le/scheme.h +++ b/boot/i3le/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/i3nt/scheme.h b/boot/i3nt/scheme.h index ded5cd7a3..f62abe512 100644 --- a/boot/i3nt/scheme.h +++ b/boot/i3nt/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/i3osx/scheme.h b/boot/i3osx/scheme.h index be6510892..82f91f7e2 100644 --- a/boot/i3osx/scheme.h +++ b/boot/i3osx/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/ta6le/scheme.h b/boot/ta6le/scheme.h index e4d2fa270..3a0cc4f31 100644 --- a/boot/ta6le/scheme.h +++ b/boot/ta6le/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef long int iptr; typedef unsigned long int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long Sint64_t; +typedef unsigned long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+9))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long); -EXPORT ptr Sunsigned64(unsigned long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/ta6nt/scheme.h b/boot/ta6nt/scheme.h index 8c47e6de1..623d86b5c 100644 --- a/boot/ta6nt/scheme.h +++ b/boot/ta6nt/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef long long int iptr; typedef unsigned long long int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+9))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/ta6osx/scheme.h b/boot/ta6osx/scheme.h index 25ae48668..8929bece8 100644 --- a/boot/ta6osx/scheme.h +++ b/boot/ta6osx/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef long int iptr; typedef unsigned long int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long Sint64_t; +typedef unsigned long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+9))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long); -EXPORT ptr Sunsigned64(unsigned long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/ti3le/scheme.h b/boot/ti3le/scheme.h index a03b10850..200745b4d 100644 --- a/boot/ti3le/scheme.h +++ b/boot/ti3le/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/ti3nt/scheme.h b/boot/ti3nt/scheme.h index 16a336978..eb0e58f4a 100644 --- a/boot/ti3nt/scheme.h +++ b/boot/ti3nt/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/boot/ti3osx/scheme.h b/boot/ti3osx/scheme.h index adaf1be48..5b0a2ec7f 100644 --- a/boot/ti3osx/scheme.h +++ b/boot/ti3osx/scheme.h @@ -45,6 +45,12 @@ typedef void * ptr; typedef int iptr; typedef unsigned int uptr; +/* Integer typedefs */ +typedef int Sint32_t; +typedef unsigned int Suint32_t; +typedef long long Sint64_t; +typedef unsigned long long Suint64_t; + /* String elements are 32-bit tagged char objects */ typedef unsigned int string_char; @@ -107,10 +113,10 @@ typedef unsigned char octet; #define Sunbox(x) (*((ptr *)((uptr)(x)+5))) EXPORT iptr Sinteger_value(ptr); #define Sunsigned_value(x) (uptr)Sinteger_value(x) -EXPORT int Sinteger32_value(ptr); -#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x) -EXPORT long long Sinteger64_value(ptr); -#define Sunsigned64_value(x) (unsigned long long)Sinteger64_value(x) +EXPORT Sint32_t Sinteger32_value(ptr); +#define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) +EXPORT Sint64_t Sinteger64_value(ptr); +#define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) /* Mutators */ EXPORT void Sset_box(ptr, ptr); @@ -146,10 +152,10 @@ EXPORT ptr Sstring_utf8(const char*, iptr); EXPORT ptr Sbox(ptr); EXPORT ptr Sinteger(iptr); EXPORT ptr Sunsigned(uptr); -EXPORT ptr Sinteger32(int); -EXPORT ptr Sunsigned32(unsigned int); -EXPORT ptr Sinteger64(long long); -EXPORT ptr Sunsigned64(unsigned long long); +EXPORT ptr Sinteger32(Sint32_t); +EXPORT ptr Sunsigned32(Suint32_t); +EXPORT ptr Sinteger64(Sint64_t); +EXPORT ptr Sunsigned64(Suint64_t); /* Miscellaneous */ EXPORT ptr Stop_level_value(ptr); diff --git a/c/number.c b/c/number.c index 61c0cf29d..28479d4da 100644 --- a/c/number.c +++ b/c/number.c @@ -329,7 +329,7 @@ I64 S_int64_value(char *who, ptr x) { return 0 /* not reached */; } -I64 Sinteger64_value(ptr x) { +Sint64_t Sinteger64_value(ptr x) { return S_int64_value("Sinteger64_value", x); } @@ -355,7 +355,7 @@ ptr Sinteger(iptr i) { /* convert arg to Scheme integer */ } } -ptr Sunsigned32(U32 u) { /* convert arg to Scheme integer */ +ptr Sunsigned32(Suint32_t u) { /* convert arg to Scheme integer */ #if (fixnum_bits > 32) return FIX((uptr)u); #else @@ -370,7 +370,7 @@ ptr Sunsigned32(U32 u) { /* convert arg to Scheme integer */ #endif } -ptr Sinteger32(I32 i) { /* convert arg to Scheme integer */ +ptr Sinteger32(Sint32_t i) { /* convert arg to Scheme integer */ #if (fixnum_bits > 32) return FIX((iptr)i); #else @@ -385,7 +385,7 @@ ptr Sinteger32(I32 i) { /* convert arg to Scheme integer */ #endif } -ptr Sunsigned64(U64 u) { /* convert arg to Scheme integer */ +ptr Sunsigned64(Suint64_t u) { /* convert arg to Scheme integer */ if (u <= most_positive_fixnum) return FIX((uptr)u); else { @@ -396,7 +396,7 @@ ptr Sunsigned64(U64 u) { /* convert arg to Scheme integer */ } } -ptr Sinteger64(I64 i) { /* convert arg to Scheme integer */ +ptr Sinteger64(Sint64_t i) { /* convert arg to Scheme integer */ if (i > most_negative_fixnum && i <= most_positive_fixnum) return FIX((iptr)i); else { diff --git a/csug/foreign.stex b/csug/foreign.stex index 7ec6f8d34..2b0647f80 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -2977,10 +2977,10 @@ or 64-bit range and return integers of the appropriate type for the machine type. \begin{flushleft} -\cfunction{<32-bit int type>}{Sinteger32_value}{ptr \var{integer}} -\cmacro{<32-bit unsigned type>}{Sunsigned32_value}{ptr \var{integer}} -\cfunction{<64-bit int type>}{Sinteger64_value}{ptr \var{integer}} -\cmacro{<64-bit unsigned type>}{Sunsigned64_value}{ptr \var{integer}} +\cfunction{Sint32_t}{Sinteger32_value}{ptr \var{integer}} +\cmacro{Suint32_t}{Sunsigned32_value}{ptr \var{integer}} +\cfunction{Sint64_t}{Sinteger64_value}{ptr \var{integer}} +\cmacro{Suint64_t}{Sunsigned64_value}{ptr \var{integer}} \end{flushleft} \noindent @@ -3169,10 +3169,10 @@ and \scheme{Sunsigned64} are like the generic equivalents but restrict their arguments to the 32- or 64-bit range. \begin{flushleft} -\cfunction{ptr}{Sinteger32}{<32-bit int type> \var{n}} -\cfunction{ptr}{Sunsigned32}{<32-bit unsigned type> \var{n}} -\cfunction{ptr}{Sinteger64}{<64-bit int type> \var{n}} -\cfunction{ptr}{Sunsigned64}{<64-bit unsigned type> \var{n}} +\cfunction{ptr}{Sinteger32}{Sint32_t \var{n}} +\cfunction{ptr}{Sunsigned32}{Suint32_t \var{n}} +\cfunction{ptr}{Sinteger64}{Sint64_t \var{n}} +\cfunction{ptr}{Sunsigned64}{Suint64_t \var{n}} \end{flushleft} \noindent diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index c27fb67e9..5e91f7a34 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,13 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{New types for code that uses C exports} + +The header file scheme.h distributed with Chez Scheme now defines +\scheme{Sint32_t}, \scheme{Suint32_t}, \scheme{Sint64_t}, and \scheme{Suint64_t} +types for 32-bit and 64-bit signed and unsigned integers that are compatible +with the types for exports such as \scheme{Sinteger64}. + \subsection{New transcoded port buffer-size parameters (9.6.0)} The new parameter \scheme{transcoded-port-buffer-size} specifies the size diff --git a/s/mkheader.ss b/s/mkheader.ss index 09c2186b4..602bf0057 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -214,6 +214,13 @@ (pr "typedef ~a iptr;~%" (constant typedef-iptr)) (pr "typedef ~a uptr;~%" (constant typedef-uptr)) + (nl) + (comment "Integer typedefs") ;; only for types used by exports + (pr "typedef ~a Sint32_t;~%" (constant typedef-i32)) + (pr "typedef ~a Suint32_t;~%" (constant typedef-u32)) + (pr "typedef ~a Sint64_t;~%" (constant typedef-i64)) + (pr "typedef ~a Suint64_t;~%" (constant typedef-u64)) + (nl) (comment "String elements are 32-bit tagged char objects") (pr "typedef ~a string_char;~%" (constant typedef-string-char)) @@ -290,10 +297,10 @@ (export "iptr" "Sinteger_value" "(ptr)") (def "Sunsigned_value(x)" "(uptr)Sinteger_value(x)") - (export (constant typedef-i32) "Sinteger32_value" "(ptr)") - (def "Sunsigned32_value(x)" (format "(~a)Sinteger32_value(x)" (constant typedef-u32))) - (export (constant typedef-i64) "Sinteger64_value" "(ptr)") - (def "Sunsigned64_value(x)" (format "(~a)Sinteger64_value(x)" (constant typedef-u64))) + (export "Sint32_t" "Sinteger32_value" "(ptr)") + (def "Sunsigned32_value(x)" "(Suint32_t)Sinteger32_value(x)") + (export "Sint64_t" "Sinteger64_value" "(ptr)") + (def "Sunsigned64_value(x)" "(Suint64_t)Sinteger64_value(x)") (nl) (comment "Mutators") (export "void" "Sset_box" "(ptr, ptr)") @@ -335,10 +342,10 @@ (export "ptr" "Sbox" "(ptr)") (export "ptr" "Sinteger" "(iptr)") (export "ptr" "Sunsigned" "(uptr)") - (export "ptr" "Sinteger32" (format "(~a)" (constant typedef-i32))) - (export "ptr" "Sunsigned32" (format "(~a)" (constant typedef-u32))) - (export "ptr" "Sinteger64" (format "(~a)" (constant typedef-i64))) - (export "ptr" "Sunsigned64" (format "(~a)" (constant typedef-u64))) + (export "ptr" "Sinteger32" "(Sint32_t)") + (export "ptr" "Sunsigned32" "(Suint32_t)") + (export "ptr" "Sinteger64" "(Sint64_t)") + (export "ptr" "Sunsigned64" "(Suint64_t)") (nl) (comment "Miscellaneous") (export "ptr" "Stop_level_value" "(ptr)") From 44207ef14b1cc503f9e7e07c1eeaa05ca92718b7 Mon Sep 17 00:00:00 2001 From: Chris Payne Date: Fri, 29 Sep 2023 14:03:42 -0400 Subject: [PATCH 3/7] add round-trip test --- mats/foreign.ms | 73 +++++++++++++++++++++++++++++++++++++++++++++++++ mats/foreign1.c | 30 ++++++++++++++++++++ 2 files changed, 103 insertions(+) diff --git a/mats/foreign.ms b/mats/foreign.ms index 004bfb506..46b3a622e 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -621,6 +621,79 @@ ($check $siv (- -1 (expt 2 100))) ) +(mat round-trip + (begin + (define rt-int (foreign-procedure "rt_int" (iptr) ptr)) + (define rt-int32 (foreign-procedure "rt_int32" (integer-32) ptr)) + (define rt-int64 (foreign-procedure "rt_int64" (integer-64) ptr)) + (define rt-uint (foreign-procedure "rt_uint" (uptr) ptr)) + (define rt-uint32 (foreign-procedure "rt_uint32" (unsigned-32) ptr)) + (define rt-uint64 (foreign-procedure "rt_uint64" (unsigned-64) ptr)) + (define (check expected ls) + (and (list? ls) + (= (length ls) 4) + (let ([expected (or expected (car ls))]) + (andmap (lambda (x) (eqv? expected x)) ls)))) + (define rt-fix (if (< (fixnum-width) 32) rt-int32 rt-int64)) + (define (check-fixnum expected) + (let ([actual (rt-fix expected)]) + (and (fixnum? expected) + (andmap fixnum? actual) + (check expected actual)))) + #t) + (check-fixnum -1) + (check-fixnum 0) + (check-fixnum 1) + (check-fixnum (most-positive-fixnum)) + (check-fixnum (most-negative-fixnum)) + + (check 0 (rt-int 0)) + (check -1 (rt-int -1)) + (check #f (rt-int (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1)))) + (check #f (rt-int (- (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1))))) + (let ([n (+ -1 (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1)))]) + (check n (rt-int n))) + (let ([n (- (ash 1 (* 8 (foreign-sizeof 'iptr))) 1)]) + (check -1 (rt-int n))) + (check 0 (rt-int32 0)) + (check -1 (rt-int32 -1)) + (check #f (rt-int32 (ash 1 31))) + (check #f (rt-int32 (- (ash 1 31)))) + (let ([n (+ -1 (ash 1 31))]) + (check n (rt-int32 n))) + (check 0 (rt-int64 0)) + (check -1 (rt-int64 -1)) + (check #f (rt-int64 (ash 1 63))) + (check #f (rt-int64 (- (ash 1 63)))) + (let ([n (+ -1 (ash 1 63))]) + (check n (rt-int64 n))) + + (check 0 (rt-uint 0)) + (check #f (rt-uint -1)) + (check #f (rt-uint (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1)))) + (check #f (rt-uint (- (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1))))) + (let ([n (+ -1 (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1)))]) + (check n (rt-uint n))) + (let ([n (- (ash 1 (* 8 (foreign-sizeof 'iptr))) 1)]) + (check n (rt-uint n))) + (check 0 (rt-uint32 0)) + (check #f (rt-uint32 -1)) + (check #f (rt-uint32 (ash 1 31))) + (check #f (rt-uint32 (- (ash 1 31)))) + (let ([n (+ -1 (ash 1 31))]) + (check n (rt-uint32 n))) + (let ([n (- (ash 1 32) 1)]) + (check n (rt-uint32 n))) + (check 0 (rt-uint64 0)) + (check #f (rt-uint64 -1)) + (check #f (rt-uint64 (ash 1 63))) + (check #f (rt-uint64 (- (ash 1 63)))) + (let ([n (+ -1 (ash 1 63))]) + (check n (rt-uint64 n))) + (let ([n (- (ash 1 64) 1)]) + (check n (rt-uint64 n))) +) + (mat foreign-sizeof (equal? (list diff --git a/mats/foreign1.c b/mats/foreign1.c index c4ac07908..d03fa89eb 100644 --- a/mats/foreign1.c +++ b/mats/foreign1.c @@ -51,6 +51,36 @@ EXPORT double float_id(double x) { return x; } +#define XMKID(prefix,bits,suffix) prefix##bits##suffix +/* build list of results matching description in foreign.stex */ +#define XIRT(name, bits, itype, utype) \ + EXPORT ptr name(itype x) { \ + ptr ls = Snil; \ + ls = Scons(Sinteger64((itype)XMKID(Sunsigned,bits,_value)(XMKID(Sunsigned,bits,)((utype)x))), ls); \ + ls = Scons(Sinteger64(XMKID(Sinteger,bits,_value)(XMKID(Sunsigned,bits,)((utype)x))), ls); \ + ls = Scons(Sinteger64((itype)XMKID(Sunsigned,bits,_value)(XMKID(Sinteger,bits,)(x))), ls); \ + ls = Scons(Sinteger64(XMKID(Sinteger,bits,_value)(XMKID(Sinteger,bits,)(x))), ls); \ + return ls; \ + } +/* build list of results matching description in foreign.stex */ +#define XURT(name, bits, itype, utype) \ + EXPORT ptr name(itype x) { \ + ptr ls = Snil; \ + ls = Scons(Sunsigned64(XMKID(Sunsigned,bits,_value)(XMKID(Sunsigned,bits,)(x))), ls); \ + ls = Scons(Sunsigned64((utype)XMKID(Sinteger,bits,_value)(XMKID(Sunsigned,bits,)(x))), ls); \ + ls = Scons(Sunsigned64(XMKID(Sunsigned,bits,_value)(XMKID(Sinteger,bits,)((itype)x))), ls); \ + ls = Scons(Sunsigned64((utype)XMKID(Sinteger,bits,_value)(XMKID(Sinteger,bits,)((itype)x))), ls); \ + return ls; \ + } + +XIRT(rt_int,,iptr,uptr) +XIRT(rt_int32,32,Sint32_t,Suint32_t) +XIRT(rt_int64,64,Sint64_t,Suint64_t) + +XURT(rt_uint,,iptr,uptr) +XURT(rt_uint32,32,Sint32_t,Suint32_t) +XURT(rt_uint64,64,Sint64_t,Suint64_t) + #ifdef _WIN32 #include From 83a6fcc6ee7b2ddfd14da536b1b2723189bee635 Mon Sep 17 00:00:00 2001 From: Chris Payne Date: Fri, 29 Sep 2023 12:40:37 -0400 Subject: [PATCH 4/7] fix most-negative-fixnum in Sinteger32, Sinteger64 --- LOG | 2 ++ c/number.c | 4 ++-- release_notes/release_notes.stex | 7 +++++++ 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/LOG b/LOG index 90c976bff..c7135d0bd 100644 --- a/LOG +++ b/LOG @@ -2445,3 +2445,5 @@ code that uses scheme.h exports boot/*/scheme.h c/number.c csug/foreign.stex release_notes/release_notes.stex s/mkheader.ss +- fix handling of most-negative-fixnum in Sinteger32 and Sinteger64 + c/number.c mats/foreign1.c mats/foreign.ms diff --git a/c/number.c b/c/number.c index 28479d4da..18881afd7 100644 --- a/c/number.c +++ b/c/number.c @@ -374,7 +374,7 @@ ptr Sinteger32(Sint32_t i) { /* convert arg to Scheme integer */ #if (fixnum_bits > 32) return FIX((iptr)i); #else - if (i > most_negative_fixnum && i <= most_positive_fixnum) + if (i >= most_negative_fixnum && i <= most_positive_fixnum) return FIX((iptr)i); else { ptr x = FIX(0); iptr xl; IBOOL xs; @@ -397,7 +397,7 @@ ptr Sunsigned64(Suint64_t u) { /* convert arg to Scheme integer */ } ptr Sinteger64(Sint64_t i) { /* convert arg to Scheme integer */ - if (i > most_negative_fixnum && i <= most_positive_fixnum) + if (i >= most_negative_fixnum && i <= most_positive_fixnum) return FIX((iptr)i); else { ptr x = FIX(0); iptr xl; IBOOL xs; diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 5e91f7a34..c7d709eca 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1973,6 +1973,13 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{\scheme{Sinteger32} and \scheme{Sinteger64} return unexpected bignum} + +When called on a C value equal to \scheme{most-negative-fixnum}, \scheme{Sinteger32} +and \scheme{Sinteger64} could return a bignum where a fixnum is expected. +The values have the same printed representation, yet comparing the resulting bignum with +\scheme{most-negative-fixnum} via Scheme's \scheme{=} returned false. + \subsection{Library-reference import syntax} A bug where \scheme{import} did not recognize a \var{library-spec} From 7e3516c8b94421da7eaac0f9ad0e46a8eef4b959 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Mon, 2 Oct 2023 12:49:20 -0400 Subject: [PATCH 5/7] fix 32-bit C integer/unsigned to bignum conversion --- LOG | 4 +++- c/number.c | 8 ++++---- release_notes/release_notes.stex | 5 +++++ 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/LOG b/LOG index c7135d0bd..4e56d75c2 100644 --- a/LOG +++ b/LOG @@ -2446,4 +2446,6 @@ boot/*/scheme.h c/number.c csug/foreign.stex release_notes/release_notes.stex s/mkheader.ss - fix handling of most-negative-fixnum in Sinteger32 and Sinteger64 - c/number.c mats/foreign1.c mats/foreign.ms + c/number.c mats/foreign1.c mats/foreign.ms release_notes/release_notes.stex +- fix 32-bit C integer/unsigned to bignum conversion + c/number.c release_notes/release_notes.stex diff --git a/c/number.c b/c/number.c index 18881afd7..c4dcaab4e 100644 --- a/c/number.c +++ b/c/number.c @@ -73,7 +73,7 @@ static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys } #define IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\ - ibigitbigit _i_ = x; bigitbigit _u_; bigit _b_;\ + ibigitbigit _i_ = x; bigitbigit _u_; bigitbigit _b_;\ PREPARE_BIGNUM(tc, B, 2)\ _u_ = (*sign = (_i_ < 0)) ? -_i_ : _i_;\ if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\ @@ -82,12 +82,12 @@ static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys } else {\ *cnt = 2;\ BIGIT(B,0) = (bigit)(_u_ >> bigit_bits);\ - BIGIT(B,1) = _b_;\ + BIGIT(B,1) = (bigit)_b_;\ }\ } #define UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) {\ - bigitbigit _u_ = x; bigit _b_;\ + bigitbigit _u_ = x; bigitbigit _b_;\ PREPARE_BIGNUM(tc, B, 2)\ if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\ *cnt = 1;\ @@ -95,7 +95,7 @@ static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys } else {\ *cnt = 2;\ BIGIT(B,0) = (bigit)(_u_ >> bigit_bits);\ - BIGIT(B,1) = _b_;\ + BIGIT(B,1) = (bigit)_b_;\ }\ } diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index c7d709eca..0615d916c 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1973,6 +1973,11 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Incorrect result from \scheme{Sinteger64} on 32-bit platforms} + +On 32-bit platforms, calling \scheme{Sinteger64} or \scheme{Sunsigned64} +with \scheme{0x8000000000000000} could return the wrong value. + \subsection{\scheme{Sinteger32} and \scheme{Sinteger64} return unexpected bignum} When called on a C value equal to \scheme{most-negative-fixnum}, \scheme{Sinteger32} From cd5d5dc7b7b8f7ab107a96c372ec7fa608cfc9b7 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Mon, 2 Oct 2023 16:29:02 -0400 Subject: [PATCH 6/7] test error cases not covered by s_test_schlib --- mats/foreign.ms | 71 +++++++++++++++++++++++++++++++++++++++++++++++++ mats/foreign1.c | 11 ++++++++ 2 files changed, 82 insertions(+) diff --git a/mats/foreign.ms b/mats/foreign.ms index 46b3a622e..f52b21460 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -694,6 +694,77 @@ (check n (rt-uint64 n))) ) +(mat convert + (begin + (define to-int (foreign-procedure "to_int" (ptr) iptr)) + (define to-int32 (foreign-procedure "to_int32" (ptr) integer-32)) + (define to-int64 (foreign-procedure "to_int64" (ptr) integer-64)) + (define to-uint (foreign-procedure "to_uint" (ptr) uptr)) + (define to-uint32 (foreign-procedure "to_uint32" (ptr) unsigned-32)) + (define to-uint64 (foreign-procedure "to_uint64" (ptr) unsigned-64)) + (define (check-error reason who f arg) + (define fp-names + (case who + [(to-int) '("Sinteger_value")] + [(to-int32) '("Sinteger32_value")] + [(to-int64) '("Sinteger64_value")] + ;; These currently call their integer counterparts and cast the + ;; result, so the condition-who will report the integer entry point. + [(to-uint) '("Sunsigned_value" "Sinteger_value")] + [(to-uint32) '("Sunsigned32_value" "Sinteger32_value")] + [(to-uint64) '("Sunsigned64_value" "Sinteger64_value")] + [else '("unexpected")])) + (guard (c [else + ;; Check error message explicitly rather than relying on the + ;; diff-based expected-error machinery since the offending + ;; values may differ on 32- vs. 64-bit platforms. + (assert (member arg (condition-irritants c))) + (assert (equal? (condition-message c) reason)) + (assert (member (condition-who c) fp-names)) + #t]) + (f arg) + #f)) + (define out-of-range "~s is out of range") + (define not-integer "~s is not an integer") + (define-syntax must-fail + (syntax-rules () + [(_ reason f n) (check-error reason 'f f n)])) + #t) + + (equal? 0 (to-int 0)) + (equal? 0 (to-int32 0)) + (equal? 0 (to-int64 0)) + (equal? 0 (to-uint 0)) + (equal? 0 (to-uint32 0)) + (equal? 0 (to-uint64 0)) + (equal? -1 (to-int -1)) + (equal? -1 (to-int32 -1)) + (equal? -1 (to-int64 -1)) + (equal? (- (ash 1 (* 8 (foreign-sizeof 'uptr))) 1) (to-uint -1)) + (equal? (- (ash 1 32) 1) (to-uint32 -1)) + (equal? (- (ash 1 64) 1) (to-uint64 -1)) + + (must-fail not-integer to-int "one") + (must-fail not-integer to-int32 'two) + (must-fail not-integer to-int64 '(3)) + (must-fail not-integer to-uint "four") + (must-fail not-integer to-uint32 'five) + (must-fail not-integer to-uint64 '(6)) + + (must-fail out-of-range to-int (ash 1 65)) + (must-fail out-of-range to-int (- (- (ash 1 (- (* 8 (foreign-sizeof 'iptr)) 1))) 1)) + (must-fail out-of-range to-int32 (ash 1 33)) + (must-fail out-of-range to-int32 (- (- (ash 1 31)) 1)) + (must-fail out-of-range to-int64 (ash 1 65)) + (must-fail out-of-range to-int64 (- (- (ash 1 63)) 1)) + (must-fail out-of-range to-uint (ash 1 65)) + (must-fail out-of-range to-uint (- (- (ash 1 (- (* 8 (foreign-sizeof 'uptr)) 1))) 1)) + (must-fail out-of-range to-uint32 (ash 1 33)) + (must-fail out-of-range to-uint32 (- (- (ash 1 31)) 1)) + (must-fail out-of-range to-uint64 (ash 1 65)) + (must-fail out-of-range to-uint64 (- (- (ash 1 63)) 1)) +) + (mat foreign-sizeof (equal? (list diff --git a/mats/foreign1.c b/mats/foreign1.c index d03fa89eb..d25c9ea0f 100644 --- a/mats/foreign1.c +++ b/mats/foreign1.c @@ -81,6 +81,17 @@ XURT(rt_uint,,iptr,uptr) XURT(rt_uint32,32,Sint32_t,Suint32_t) XURT(rt_uint64,64,Sint64_t,Suint64_t) +#define XTOI(name, bits, type) EXPORT type name(ptr x) { return XMKID(Sinteger,bits,_value)(x); } +#define XTOU(name, bits, type) EXPORT type name(ptr x) { return XMKID(Sunsigned,bits,_value)(x); } + +XTOI(to_int,,iptr) +XTOI(to_int32,32,Sint32_t) +XTOI(to_int64,64,Sint64_t) + +XTOU(to_uint,,uptr) +XTOU(to_uint32,32,Suint32_t) +XTOU(to_uint64,64,Suint64_t) + #ifdef _WIN32 #include From 629afef14956fe6816a710ceceec204061ab1ba1 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Tue, 3 Oct 2023 10:41:59 -0400 Subject: [PATCH 7/7] add non-throwing Scheme to C integer conversions --- LOG | 6 ++ boot/a6le/scheme.h | 6 ++ boot/a6nt/scheme.h | 6 ++ boot/a6osx/scheme.h | 6 ++ boot/arm32le/scheme.h | 6 ++ boot/i3le/scheme.h | 6 ++ boot/i3nt/scheme.h | 6 ++ boot/i3osx/scheme.h | 6 ++ boot/ta6le/scheme.h | 6 ++ boot/ta6nt/scheme.h | 6 ++ boot/ta6osx/scheme.h | 6 ++ boot/ti3le/scheme.h | 6 ++ boot/ti3nt/scheme.h | 6 ++ boot/ti3osx/scheme.h | 6 ++ c/externs.h | 1 - c/number.c | 141 +++++++++++++++++-------------- c/scheme.c | 6 +- csug/foreign.stex | 29 +++++++ mats/foreign.ms | 92 ++++++++++++++++++++ mats/foreign1.c | 23 +++++ release_notes/release_notes.stex | 17 ++++ s/mkheader.ss | 6 ++ 22 files changed, 333 insertions(+), 66 deletions(-) diff --git a/LOG b/LOG index 4e56d75c2..7c3a33577 100644 --- a/LOG +++ b/LOG @@ -2449,3 +2449,9 @@ c/number.c mats/foreign1.c mats/foreign.ms release_notes/release_notes.stex - fix 32-bit C integer/unsigned to bignum conversion c/number.c release_notes/release_notes.stex +- add functions that try to convert from Scheme to C signed and unsigned + integers without throwing exceptions; use the new functions in Sscheme_start + and run_script + boot/*/scheme.h c/externs.h c/number.c c/scheme.c csug/foreign.stex + mats/foreign1.c mats/foreign.ms release_notes/release_notes.stex + s/mkheader.ss diff --git a/boot/a6le/scheme.h b/boot/a6le/scheme.h index fe91fc4f3..b61af17c7 100644 --- a/boot/a6le/scheme.h +++ b/boot/a6le/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/a6nt/scheme.h b/boot/a6nt/scheme.h index 3dffd074f..73843740b 100644 --- a/boot/a6nt/scheme.h +++ b/boot/a6nt/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/a6osx/scheme.h b/boot/a6osx/scheme.h index ea1b2fa5c..75771854c 100644 --- a/boot/a6osx/scheme.h +++ b/boot/a6osx/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/arm32le/scheme.h b/boot/arm32le/scheme.h index 6fb06c2ab..d4a85260c 100644 --- a/boot/arm32le/scheme.h +++ b/boot/arm32le/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/i3le/scheme.h b/boot/i3le/scheme.h index 43cb78f71..ddca3f4b0 100644 --- a/boot/i3le/scheme.h +++ b/boot/i3le/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/i3nt/scheme.h b/boot/i3nt/scheme.h index f62abe512..92441dbcc 100644 --- a/boot/i3nt/scheme.h +++ b/boot/i3nt/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/i3osx/scheme.h b/boot/i3osx/scheme.h index 82f91f7e2..a36ebf2c7 100644 --- a/boot/i3osx/scheme.h +++ b/boot/i3osx/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/ta6le/scheme.h b/boot/ta6le/scheme.h index 3a0cc4f31..98a8fd87d 100644 --- a/boot/ta6le/scheme.h +++ b/boot/ta6le/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/ta6nt/scheme.h b/boot/ta6nt/scheme.h index 623d86b5c..18ac6aba7 100644 --- a/boot/ta6nt/scheme.h +++ b/boot/ta6nt/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/ta6osx/scheme.h b/boot/ta6osx/scheme.h index 8929bece8..34d3d987d 100644 --- a/boot/ta6osx/scheme.h +++ b/boot/ta6osx/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/ti3le/scheme.h b/boot/ti3le/scheme.h index 200745b4d..add0092d5 100644 --- a/boot/ti3le/scheme.h +++ b/boot/ti3le/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/ti3nt/scheme.h b/boot/ti3nt/scheme.h index eb0e58f4a..6e79cf86e 100644 --- a/boot/ti3nt/scheme.h +++ b/boot/ti3nt/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/boot/ti3osx/scheme.h b/boot/ti3osx/scheme.h index 5b0a2ec7f..4e76d3bc0 100644 --- a/boot/ti3osx/scheme.h +++ b/boot/ti3osx/scheme.h @@ -116,7 +116,13 @@ EXPORT iptr Sinteger_value(ptr); EXPORT Sint32_t Sinteger32_value(ptr); #define Sunsigned32_value(x) (Suint32_t)Sinteger32_value(x) EXPORT Sint64_t Sinteger64_value(ptr); +EXPORT int Stry_integer_value(ptr, iptr*, const char**); +EXPORT int Stry_integer32_value(ptr, Sint32_t*, const char**); +EXPORT int Stry_integer64_value(ptr, Sint64_t*, const char**); #define Sunsigned64_value(x) (Suint64_t)Sinteger64_value(x) +EXPORT int Stry_unsigned_value(ptr, uptr*, const char**); +EXPORT int Stry_unsigned32_value(ptr, Suint32_t*, const char**); +EXPORT int Stry_unsigned64_value(ptr, Suint64_t*, const char**); /* Mutators */ EXPORT void Sset_box(ptr, ptr); diff --git a/c/externs.h b/c/externs.h index c069cea49..00a519993 100644 --- a/c/externs.h +++ b/c/externs.h @@ -260,7 +260,6 @@ extern void S_generic_invoke(ptr tc, ptr code); /* number.c */ extern void S_number_init(void); extern ptr S_normalize_bignum(ptr x); -extern IBOOL S_integer_valuep(ptr x); extern iptr S_integer_value(const char *who, ptr x); extern I64 S_int64_value(char *who, ptr x); extern IBOOL S_big_eq(ptr x, ptr y); diff --git a/c/number.c b/c/number.c index c4dcaab4e..dc701dba6 100644 --- a/c/number.c +++ b/c/number.c @@ -202,14 +202,17 @@ static ptr copy_normalize(ptr tc, const bigit *p, iptr len, IBOOL sign) { return b; } +#define RETURN_STRY_OK(expr) { *val = expr; return 1; } +#define RETURN_STRY_ERROR(why) { if (reason) *reason = why; return 0; } + /* -2^(b-1) <= x <= 2^b-1, where b = number of bits in a uptr */ -iptr S_integer_value(const char *who, ptr x) { - if (Sfixnump(x)) return UNFIX(x); +IBOOL Stry_integer_value(ptr x, iptr *val, const char** reason) { + if (Sfixnump(x)) RETURN_STRY_OK(UNFIX(x)) if (Sbignump(x)) { iptr xl; uptr u; - if ((xl = BIGLEN(x)) > ptr_bigits) S_error1(who, "~s is out of range", x); + if ((xl = BIGLEN(x)) > ptr_bigits) RETURN_STRY_ERROR("~s is out of range") u = BIGIT(x,0); @@ -217,69 +220,48 @@ iptr S_integer_value(const char *who, ptr x) { if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); #endif - if (!BIGSIGN(x)) return (iptr)u; - if (u < ((uptr)1 << (ptr_bits - 1))) return -(iptr)u; - if (u > ((uptr)1 << (ptr_bits - 1))) S_error1(who, "~s is out of range", x); + if (!BIGSIGN(x)) RETURN_STRY_OK((iptr)u) + if (u < ((uptr)1 << (ptr_bits - 1))) RETURN_STRY_OK(-(iptr)u) + if (u > ((uptr)1 << (ptr_bits - 1))) RETURN_STRY_ERROR("~s is out of range") #if (fixnum_bits > 32) - return (iptr)0x8000000000000000; + RETURN_STRY_OK((iptr)0x8000000000000000) #else - return (iptr)0x80000000; + RETURN_STRY_OK((iptr)0x80000000) #endif } - S_error1(who, "~s is not an integer", x); - - return 0 /* not reached */; -} - -/* -2^(b-1) <= x <= 2^b-1, where b = number of bits in a uptr */ -IBOOL S_integer_valuep(ptr x) { - if (Sfixnump(x)) return 1; - - if (Sbignump(x)) { - iptr xl; uptr u; - - if ((xl = BIGLEN(x)) > ptr_bigits) return 0; - - u = BIGIT(x,0); - -#if (ptr_bigits == 2) - if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); -#endif - - if (!BIGSIGN(x)) return 1; - return u <= ((uptr)1 << (ptr_bits - 1)); - } - - return 0; + RETURN_STRY_ERROR("~s is not an integer") } iptr Sinteger_value(ptr x) { - return S_integer_value("Sinteger_value", x); + iptr result; + const char* reason; + if (Stry_integer_value(x, &result, &reason)) return result; + S_error1("Sinteger_value", reason, x); } /* -2^31 <= x <= 2^32-1 */ -I32 S_int32_value(char *who, ptr x) { +IBOOL Stry_integer32_value(ptr x, Sint32_t* val, const char** reason) { #if (fixnum_bits > 32) if (Sfixnump(x)) { iptr n = UNFIX(x); if (n < 0) { - I32 m = (I32)n; - if ((iptr)m == UNFIX(x)) return m; + Sint32_t m = (Sint32_t)n; + if ((iptr)m == UNFIX(x)) RETURN_STRY_OK(m) } else { - U32 m = (U32)n; - if ((uptr)m == (uptr)UNFIX(x)) return (I32)m; + Suint32_t m = (Suint32_t)n; + if ((uptr)m == (uptr)UNFIX(x)) RETURN_STRY_OK((Sint32_t)m) } - S_error1(who, "~s is out of range", x); + RETURN_STRY_ERROR("~s is out of range") } - if (Sbignump(x)) S_error1(who, "~s is out of range", x); + if (Sbignump(x)) RETURN_STRY_ERROR("~s is out of range") #else /* (fixnum_bits > 32) */ - if (Sfixnump(x)) return UNFIX(x); + if (Sfixnump(x)) RETURN_STRY_OK(UNFIX(x)) if (Sbignump(x)) { - iptr xl; U32 u; + iptr xl; Suint32_t u; - if ((xl = BIGLEN(x)) > U32_bigits) S_error1(who, "~s is out of range", x); + if ((xl = BIGLEN(x)) > U32_bigits) RETURN_STRY_ERROR("~s is out of range") u = BIGIT(x,0); @@ -287,30 +269,31 @@ I32 S_int32_value(char *who, ptr x) { if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); #endif - if (!BIGSIGN(x)) return (I32)u; - if (u < ((U32)1 << 31)) return -(I32)u; - if (u > ((U32)1 << 31)) S_error1(who, "~s is out of range", x); - return (I32)0x80000000; + if (!BIGSIGN(x)) RETURN_STRY_OK((Sint32_t)u) + if (u < ((Suint32_t)1 << 31)) RETURN_STRY_OK(-(Sint32_t)u) + if (u > ((Suint32_t)1 << 31)) RETURN_STRY_ERROR("~s is out of range") + RETURN_STRY_OK((Sint32_t)0x80000000) } #endif /* (fixnum_bits > 32) */ - S_error1(who, "~s is not an integer", x); - - return 0 /* not reached */; + RETURN_STRY_ERROR("~s is not an integer") } -I32 Sinteger32_value(ptr x) { - return S_int32_value("Sinteger32_value", x); +Sint32_t Sinteger32_value(ptr x) { + Sint32_t result; + const char* reason; + if (Stry_integer32_value(x, &result, &reason)) return result; + S_error1("Sinteger32_value", reason, x); } /* -2^63 <= x <= 2^64-1 */ -I64 S_int64_value(char *who, ptr x) { - if (Sfixnump(x)) return UNFIX(x); +IBOOL Stry_integer64_value(ptr x, Sint64_t *val, const char** reason) { + if (Sfixnump(x)) RETURN_STRY_OK(UNFIX(x)) if (Sbignump(x)) { - iptr xl; U64 u; + iptr xl; Suint64_t u; - if ((xl = BIGLEN(x)) > U64_bigits) S_error1(who, "~s is out of range", x); + if ((xl = BIGLEN(x)) > U64_bigits) RETURN_STRY_ERROR("~s is out of range") u = BIGIT(x,0); @@ -318,21 +301,53 @@ I64 S_int64_value(char *who, ptr x) { if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1); #endif - if (!BIGSIGN(x)) return (I64)u; - if (u < ((U64)1 << 63)) return -(I64)u; - if (u > ((U64)1 << 63)) S_error1(who, "~s is out of range", x); - return (I64)0x8000000000000000; + if (!BIGSIGN(x)) RETURN_STRY_OK((Sint64_t)u) + if (u < ((Suint64_t)1 << 63)) RETURN_STRY_OK(-(Sint64_t)u) + if (u > ((Suint64_t)1 << 63)) RETURN_STRY_ERROR("~s is out of range") + RETURN_STRY_OK((Sint64_t)0x8000000000000000) } - S_error1(who, "~s is not an integer", x); + RETURN_STRY_ERROR("~s is not an integer") +} - return 0 /* not reached */; +I64 S_int64_value(char *who, ptr x) { + Sint64_t result; + const char* reason; + if (Stry_integer64_value(x, &result, &reason)) return result; + S_error1(who, reason, x); } Sint64_t Sinteger64_value(ptr x) { return S_int64_value("Sinteger64_value", x); } +IBOOL Stry_unsigned_value(ptr x, uptr* val, const char** reason) { + iptr tmp; + if (Stry_integer_value(x, &tmp, reason)) { + *val = (uptr)tmp; + return 1; + } + return 0; +} + +IBOOL Stry_unsigned32_value(ptr x, Suint32_t* val, const char** reason) { + Sint32_t tmp; + if (Stry_integer32_value(x, &tmp, reason)) { + *val = (Suint32_t)tmp; + return 1; + } + return 0; +} + +IBOOL Stry_unsigned64_value(ptr x, Suint64_t* val, const char** reason) { + Sint64_t tmp; + if (Stry_integer64_value(x, &tmp, reason)) { + *val = (Suint64_t)tmp; + return 1; + } + return 0; +} + ptr Sunsigned(uptr u) { /* convert arg to Scheme integer */ if (u <= most_positive_fixnum) return FIX(u); diff --git a/c/scheme.c b/c/scheme.c index 23ea009c5..286894608 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -1202,7 +1202,8 @@ extern INT Sscheme_start(INT argc, const char *argv[]) { S_put_arg(tc, 1, arglist); p = boot_call(tc, p, 1); - if (S_integer_valuep(p)) return (INT)Sinteger_value(p); + iptr result; + if (Stry_integer_value(p, &result, NULL)) return (INT)result; return p == Svoid ? 0 : 1; } @@ -1240,7 +1241,8 @@ static INT run_script(const char *who, const char *scriptfile, INT argc, const c S_put_arg(tc, 3, arglist); p = boot_call(tc, p, 3); - if (S_integer_valuep(p)) return (INT)Sinteger_value(p); + iptr result; + if (Stry_integer_value(p, &result, NULL)) return (INT)result; return p == Svoid ? 0 : 1; } diff --git a/csug/foreign.stex b/csug/foreign.stex index 2b0647f80..2e380079d 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -2983,6 +2983,35 @@ type for the machine type. \cmacro{Suint64_t}{Sunsigned64_value}{ptr \var{integer}} \end{flushleft} +The functions +\scheme{Stry_integer_value}, +\scheme{Stry_integer32_value}, and +\scheme{Stry_integer64_value} +also convert Scheme values to C integers. +Unlike the corresponding \scheme{Sinteger_value} functions, these functions do not raise exceptions. +Instead, they take additional \var{result} and \var{reason} arguments +and return 1 or 0 to indicate success or failure. +If \var{integer} can be converted to the requested type, these functions store +the value in \var{result} and return 1. +Otherwise, they return 0 without modifying \var{result}. +If \var{integer} cannot be converted to the requested type and +\var{reason} is not NULL, these functions store a +Scheme-style +format string in \var{reason} explaining why the conversion failed. +The corresponding functions for unsigned values are +\scheme{Stry_unsigned_value}, +\scheme{Stry_unsigned32_value}, and +\scheme{Stry_unsigned64_value}. + +\begin{flushleft} +\cfunction{int}{Stry_integer_value}{ptr \var{integer}, iptr* \var{result}, const char** \var{reason}} +\cfunction{int}{Stry_integer32_value}{ptr \var{integer}, Sint32_t* \var{result}, const char** \var{reason}} +\cfunction{int}{Stry_integer64_value}{ptr \var{integer}, Sint64_t* \var{result}, const char** \var{reason}} +\cfunction{int}{Stry_unsigned_value}{ptr \var{integer}, uptr* \var{result}, const char** \var{reason}} +\cfunction{int}{Stry_unsigned32_value}{ptr \var{integer}, Suint32_t* \var{result}, const char** \var{reason}} +\cfunction{int}{Stry_unsigned64_value}{ptr \var{integer}, Suint64_t* \var{result}, const char** \var{reason}} +\end{flushleft} + \noindent \scheme{Scar}, \scheme{Scdr}, \scheme{Ssymbol_to_string} (corresponding to \scheme{symbol->string}), and \scheme{Sunbox} are identical to their diff --git a/mats/foreign.ms b/mats/foreign.ms index f52b21460..e5251e86f 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -765,6 +765,98 @@ (must-fail out-of-range to-uint64 (- (- (ash 1 63)) 1)) ) +(mat try-convert + (begin + (define m-p-f (most-positive-fixnum)) + (define m-n-f (most-negative-fixnum)) + (define ptr-bits (* 8 (foreign-sizeof 'ptr))) + (define (test signed? bits prefix in-range* out-of-range*) + (define sign-bit (and signed? (- bits 1))) + (define fp-v2 (foreign-procedure (format "~a2" prefix) (ptr) ptr)) + (define fp-v3 (foreign-procedure (format "~a3" prefix) (ptr) ptr)) + (define (fp-name fp) + (format "~a~a" prefix (assert (cond [(eq? fp fp-v2) 2] [(eq? fp fp-v3) 3] [else #f])))) + (define (expect expected fp arg) + (let ([actual (fp arg)]) + (unless (equal? expected actual) + (errorf #f "expected ~s but got ~s from ~a on ~s\n" expected actual (fp-name fp) arg)))) + (define in-range-for-all* + (let ([ls (list 1 7654321 #xffffff #xffffff0)]) + (cons 0 + (if (not sign-bit) + ls + (append ls (map - ls) + (let ([hi (ash 1 sign-bit)]) + (list hi (- hi) (+ (- hi) 1) (+ hi 1)))))))) + (define out-of-range-for-all* + (let ([ls (list #e1e30 #e-1e30 (ash 1 64) (- (ash 1 64)))]) + (if (not sign-bit) + ls + (let ([hi (ash 1 (+ sign-bit 1))]) + (list* hi (- hi) (- (- hi) 123) (+ hi 27) (- (- (ash hi -1)) 1) ls))))) + (assert (string=? (substring prefix 4 7) (if sign-bit "int" "uns"))) + ;; try some non-integer cases + (for-each + (lambda (bogus) + (expect '(0 0) fp-v2 bogus) + (expect '(0 0 "~s is not an integer") fp-v3 bogus)) + '(#f 0.0 #t 3.2 "wrong" bad)) + ;; try in-range cases + (for-each + (lambda (good) + (define expected + (if (not sign-bit) + (if (< good 0) + (bitwise-bit-field (bitwise-not (- -1 good)) 0 bits) + good) + (if (or (< good 0) (not (logbit? sign-bit good))) + good + (- (bitwise-bit-field (+ (bitwise-not good) 1) 0 (+ sign-bit 1)))))) + (expect `(1 ,expected) fp-v2 good) + (expect `(1 ,expected "untouched") fp-v3 good)) + (append in-range-for-all* in-range*)) + ;; try out-of-range cases + (for-each + (lambda (bad) + (expect '(0 0) fp-v2 bad) + (expect `(0 0 "~s is out of range") fp-v3 bad)) + (append out-of-range-for-all* out-of-range*)) + #t) + #t) + (test #t ptr-bits "try_integer_value" + (list ;; extra in-range checks + m-n-f + m-p-f + ;; hit third return in bignum case + (- m-n-f 1) + (+ m-p-f 1)) + '()) + (test #t 32 "try_integer32_value" '() '()) + (test #t 64 "try_integer64_value" + (list m-p-f m-n-f + (ash 1 60) + (ash 1 61) + (ash 1 62) + (- -1 (ash 1 60)) + (- -1 (ash 1 61)) + (- -1 (ash 1 62))) + '()) + (test #f ptr-bits "try_unsigned_value" + (list m-p-f (+ m-p-f 1) m-n-f + (- (ash 1 (- ptr-bits 1))) + (- (- (ash 1 (- ptr-bits 1)) 1))) + (list (- (+ (ash 1 (- ptr-bits 1)) 1)))) + (test #f 32 "try_unsigned32_value" + (list + (+ (ash 1 30) 1) + (- (+ (ash 1 30) 1)) + (- (ash 1 31))) + (list (ash 1 32) (- (ash 1 32)) (- -1 (ash 1 31)))) + (test #f 64 "try_unsigned64_value" + (list m-p-f (+ m-p-f 1) m-n-f (- 1 (ash 1 63)) #x-8000000000000000) + (list (- -1 (ash 1 63)))) +) + (mat foreign-sizeof (equal? (list diff --git a/mats/foreign1.c b/mats/foreign1.c index d25c9ea0f..c17b03897 100644 --- a/mats/foreign1.c +++ b/mats/foreign1.c @@ -92,6 +92,29 @@ XTOU(to_uint,,uptr) XTOU(to_uint32,32,Suint32_t) XTOU(to_uint64,64,Suint64_t) +#define XID(name,num) name##num +#define XSID(name) S##name + +#define XTRY(name, type, rproc) \ + EXPORT ptr XID(name, 2)(ptr p) { \ + type i = 0; \ + int success = XSID(name)(p, &i, 0); \ + return Scons(Sinteger(success), Scons(rproc(i), Snil)); \ + } \ + EXPORT ptr XID(name, 3)(ptr p) { \ + type i = 0; \ + const char *reason = "untouched"; \ + int success = XSID(name)(p, &i, &reason); \ + return Scons(Sinteger(success), Scons(rproc(i), Scons(Sstring(reason), Snil))); \ + } + +XTRY(try_integer_value, iptr, Sinteger) +XTRY(try_integer32_value, Sint32_t, Sinteger32) +XTRY(try_integer64_value, Sint64_t, Sinteger64) +XTRY(try_unsigned_value, uptr, Sunsigned) +XTRY(try_unsigned32_value, Suint32_t, Sunsigned32) +XTRY(try_unsigned64_value, Suint64_t, Sunsigned64) + #ifdef _WIN32 #include diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 0615d916c..9f4adc8c3 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,23 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{New conversions from Scheme to C signed and unsigned integers} + +The following new functions +allow foreign code to try converting Scheme +values to signed or unsigned integer values +without triggering a \scheme{longjmp} in the Scheme runtime +as can happen when calling the corresponding functions +\scheme{Sinteger_value}, etc: +\schemedisplay +Stry_integer_value +Stry_integer32_value +Stry_integer64_value +Stry_unsigned_value +Stry_unsigned32_value +Stry_unsigned64_value +\endschemedisplay + \subsection{New types for code that uses C exports} The header file scheme.h distributed with Chez Scheme now defines diff --git a/s/mkheader.ss b/s/mkheader.ss index 602bf0057..b9090e89f 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -300,7 +300,13 @@ (export "Sint32_t" "Sinteger32_value" "(ptr)") (def "Sunsigned32_value(x)" "(Suint32_t)Sinteger32_value(x)") (export "Sint64_t" "Sinteger64_value" "(ptr)") + (export "int" "Stry_integer_value" "(ptr, iptr*, const char**)") + (export "int" "Stry_integer32_value" "(ptr, Sint32_t*, const char**)") + (export "int" "Stry_integer64_value" "(ptr, Sint64_t*, const char**)") (def "Sunsigned64_value(x)" "(Suint64_t)Sinteger64_value(x)") + (export "int" "Stry_unsigned_value" "(ptr, uptr*, const char**)") + (export "int" "Stry_unsigned32_value" "(ptr, Suint32_t*, const char**)") + (export "int" "Stry_unsigned64_value" "(ptr, Suint64_t*, const char**)") (nl) (comment "Mutators") (export "void" "Sset_box" "(ptr, ptr)")