From 629afef14956fe6816a710ceceec204061ab1ba1 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Tue, 3 Oct 2023 10:41:59 -0400 Subject: [PATCH] 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)")