diff --git a/LOG b/LOG index 4d8646a0c..7c3a33577 100644 --- a/LOG +++ b/LOG @@ -2441,3 +2441,17 @@ 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 +- fix handling of most-negative-fixnum in Sinteger32 and Sinteger64 + 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 4ed47ea1e..b61af17c7 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,16 @@ 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); +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); @@ -146,10 +158,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..73843740b 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,16 @@ 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); +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); @@ -146,10 +158,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..75771854c 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,16 @@ 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); +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); @@ -146,10 +158,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..d4a85260c 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,16 @@ 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); +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); @@ -146,10 +158,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..ddca3f4b0 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,16 @@ 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); +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); @@ -146,10 +158,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..92441dbcc 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,16 @@ 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); +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); @@ -146,10 +158,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..a36ebf2c7 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,16 @@ 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); +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); @@ -146,10 +158,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..98a8fd87d 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,16 @@ 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); +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); @@ -146,10 +158,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..18ac6aba7 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,16 @@ 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); +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); @@ -146,10 +158,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..34d3d987d 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,16 @@ 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); +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); @@ -146,10 +158,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..add0092d5 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,16 @@ 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); +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); @@ -146,10 +158,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..6e79cf86e 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,16 @@ 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); +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); @@ -146,10 +158,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..4e76d3bc0 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,16 @@ 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); +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); @@ -146,10 +158,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/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 61c0cf29d..dc701dba6 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_;\ }\ } @@ -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); } -I64 Sinteger64_value(ptr 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); @@ -355,7 +370,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,11 +385,11 @@ 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 - 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; @@ -385,7 +400,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,8 +411,8 @@ ptr Sunsigned64(U64 u) { /* convert arg to Scheme integer */ } } -ptr Sinteger64(I64 i) { /* convert arg to Scheme integer */ - if (i > most_negative_fixnum && i <= most_positive_fixnum) +ptr Sinteger64(Sint64_t i) { /* convert arg to Scheme integer */ + 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/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 e42c4329f..2e380079d 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -2977,10 +2977,39 @@ 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} + +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 @@ -3134,7 +3163,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 @@ -3169,10 +3198,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/mats/foreign.ms b/mats/foreign.ms index 004bfb506..e5251e86f 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -621,6 +621,242 @@ ($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 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 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 c4ac07908..c17b03897 100644 --- a/mats/foreign1.c +++ b/mats/foreign1.c @@ -51,6 +51,70 @@ 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) + +#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) + +#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 c27fb67e9..9f4adc8c3 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,30 @@ 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 +\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 @@ -1966,6 +1990,18 @@ 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} +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} diff --git a/s/mkheader.ss b/s/mkheader.ss index 09c2186b4..b9090e89f 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,16 @@ (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)") + (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)") @@ -335,10 +348,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)")