~ chicken-core (chicken-5) a3f09e53101c34fd161dc00e04f575304ffd5be3
commit a3f09e53101c34fd161dc00e04f575304ffd5be3
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue May 26 22:38:44 2015 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:56:14 2015 +0200
Also perform range checks on foreign integer argument types.
Enforce integers to lie within the range representable by the foreign
type. This simplifies runtime a little by passing the size in bits to
the checking procedure. This allows us to replace the four procedures
sys#foreign-[unsigned-]integer[64]-argument with the two procedures
sys#foreign-[unsigned-]ranged-integer-argument.
This is more correct for highly system-dependent types like size_t,
which may be 32 bits or 64 bits on different systems. Otherwise, we
would have to add these 8 missing procedures:
- sys#foreign-[unsigned-]integer32-argument
- sys#foreign-[unsigned-]short-argument
- sys#foreign-[unsigned-]long-argument
- sys#foreign-[unsigned-]size_t-argument
diff --git a/c-platform.scm b/c-platform.scm
index 8e4525eb..62df0f4f 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -196,7 +196,7 @@
##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
##sys#foreign-block-argument ##sys#foreign-struct-wrapper-argument
##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
- ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument
+ ##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument
##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte
##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd))
@@ -818,8 +818,8 @@
(rewrite '##sys#foreign-struct-wrapper-argument 17 2 "C_i_foreign_struct_wrapper_argumentp")
(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")
(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")
-(rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp")
-(rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp")
+(rewrite '##sys#foreign-ranged-integer-argument 17 2 "C_i_foreign_ranged_integer_argumentp")
+(rewrite '##sys#foreign-unsigned-ranged-integer-argument 17 2 "C_i_foreign_unsigned_ranged_integer_argumentp")
(rewrite '##sys#direct-return 17 2 "C_direct_return")
(rewrite 'blob-size 2 1 "C_block_size" #f)
diff --git a/chicken.h b/chicken.h
index f268077f..0b7bd0b0 100644
--- a/chicken.h
+++ b/chicken.h
@@ -2200,10 +2200,16 @@ C_fctexport C_word C_fcall C_i_foreign_symbol_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_pointer_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_foreign_integer_argumentp(C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_foreign_integer64_argumentp(C_word x) C_regparm;
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_fctexport C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
C_fctexport C_char *C_lookup_procedure_id(void *ptr);
C_fctexport void *C_lookup_procedure_ptr(C_char *id);
diff --git a/library.scm b/library.scm
index be457081..caac0830 100644
--- a/library.scm
+++ b/library.scm
@@ -5130,14 +5130,19 @@ EOF
(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))
(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))
(define (##sys#foreign-integer-argument x) (##core#inline "C_i_foreign_integer_argumentp" x))
+;; OBSOLETE
(define (##sys#foreign-integer64-argument x) (##core#inline "C_i_foreign_integer64_argumentp" x))
-
+;; OBSOLETE
(define (##sys#foreign-unsigned-integer-argument x)
(##core#inline "C_i_foreign_unsigned_integer_argumentp" x))
-
+;; OBSOLETE
(define (##sys#foreign-unsigned-integer64-argument x)
(##core#inline "C_i_foreign_unsigned_integer64_argumentp" x))
+(define (##sys#foreign-ranged-integer-argument obj size)
+ (##core#inline "C_i_foreign_ranged_integer_argumentp" obj size))
+(define (##sys#foreign-unsigned-ranged-integer-argument obj size)
+ (##core#inline "C_i_foreign_unsigned_ranged_integer_argumentp" obj size))
;;; Low-level threading interface:
diff --git a/runtime.c b/runtime.c
index 717f2d58..bbd16f6e 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5885,6 +5885,19 @@ C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word
else return C_flonum(a, nn1);
}
+/* Faster version that ignores sign in bignums. TODO: Omit labs() too? */
+C_inline int integer_length_abs(C_word x)
+{
+ if (x & C_FIXNUM_BIT) {
+ return C_ilen(labs(C_unfix(x)));
+ } else {
+ C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,
+ *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,
+ last_digit_length = C_ilen(*last_digit);
+ return result + last_digit_length;
+ }
+}
+
C_regparm C_word C_fcall C_i_integer_length(C_word x)
{
if (x & C_FIXNUM_BIT) {
@@ -6931,7 +6944,36 @@ C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t
return x;
}
+C_regparm C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)
+{
+ if((x & C_FIXNUM_BIT) != 0) {
+ if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;
+ else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
+ } else if (C_truep(C_i_bignump(x))) {
+ if (C_truep(C_fixnum_lessp(C_i_integer_length(x), bits))) return x;
+ else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
+ }
+}
+
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
+C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)
+{
+ if((x & C_FIXNUM_BIT) != 0) {
+ if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
+ else if(C_ilen(C_unfix(x)) <= C_unfix(bits)) return x;
+ else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
+ } else if(C_truep(C_i_bignump(x))) {
+ if(C_bignum_negativep(x)) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
+ else if(integer_length_abs(x) <= C_unfix(bits)) return x;
+ else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
+ } else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
+ }
+}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
{
double m;
@@ -6955,6 +6997,7 @@ C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_i_foreign_integer64_argumentp(C_word x)
{
double m, r;
@@ -6982,6 +7025,7 @@ C_regparm C_word C_fcall C_i_foreign_integer64_argumentp(C_word x)
}
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
{
double m ,r;
@@ -6993,7 +7037,6 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
}
- /* XXX OBSOLETE: This should be removed on the next round */
if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
m = C_flonum_magnitude(x);
@@ -7004,7 +7047,7 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
return C_SCHEME_UNDEFINED;
}
-
+/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
{
double m, r;
@@ -7020,7 +7063,6 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
}
- /* XXX OBSOLETE: This should be removed on the next round */
if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
m = C_flonum_magnitude(x);
@@ -8628,18 +8670,6 @@ bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)
}
}
-C_inline int integer_length_abs(C_word x)
-{
- if (x & C_FIXNUM_BIT) {
- return C_ilen(labs(C_unfix(x)));
- } else {
- C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,
- *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,
- last_digit_length = C_ilen(*last_digit);
- return result + last_digit_length;
- }
-}
-
/* Burnikel-Ziegler recursive division: Split high number (x) in three
* or four parts and divide by the lowest number (y), split in two
* parts. There are descriptions in [MpNT, 4.2], [MCA, 1.4.3] and the
diff --git a/support.scm b/support.scm
index 4cd67379..580d91d8 100644
--- a/support.scm
+++ b/support.scm
@@ -956,7 +956,13 @@
(nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
(nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
(nonnull-u64vector . u64vector) (nonnull-s64vector . s64vector)
- (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector))))
+ (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector)))
+ (ftmap '((integer . "int") (unsigned-integer . "unsigned int")
+ (integer32 . "C_s32") (unsigned-integer32 . "C_u32")
+ (integer64 . "C_s64") (unsigned-integer64 . "C_u64")
+ (short . "short") (unsigned-short . "unsigned short")
+ (long . "long") (unsigned-long . "unsigned long")
+ (size_t . "size_t"))))
(lambda (param type)
(follow-without-loop
type
@@ -964,7 +970,8 @@
(let repeat ((t t))
(case t
((char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param)))
- ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
+ ;; TODO: Should "[unsigned-]byte" be range checked?
+ ((int unsigned-int byte unsigned-byte int32 unsigned-int32)
(if unsafe param `(##sys#foreign-fixnum-argument ,param)))
((float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param)))
((blob scheme-pointer)
@@ -1010,18 +1017,21 @@
`(##sys#foreign-struct-wrapper-argument
',(##sys#slot (assq t tmap) 1)
,param) ) )
- ((integer long size_t integer32)
- (if unsafe param `(##sys#foreign-integer-argument ,param)))
- ((integer64)
- (if unsafe param `(##sys#foreign-integer64-argument ,param)))
- ((unsigned-integer unsigned-integer32 unsigned-long)
- (if unsafe
- param
- `(##sys#foreign-unsigned-integer-argument ,param) ) )
- ((unsigned-integer64)
- (if unsafe
- param
- `(##sys#foreign-unsigned-integer64-argument ,param) ) )
+ ((integer32 integer64 integer short long size_t)
+ (let* ((foreign-type (##sys#slot (assq t ftmap) 1))
+ (size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
+ (if unsafe
+ param
+ `(##sys#foreign-ranged-integer-argument
+ ,param (foreign-value ,size-expr int)))))
+ ((unsigned-short unsigned-long unsigned-integer
+ unsigned-integer32 unsigned-integer64)
+ (let* ((foreign-type (##sys#slot (assq t ftmap) 1))
+ (size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
+ (if unsafe
+ param
+ `(##sys#foreign-unsigned-ranged-integer-argument
+ ,param (foreign-value ,size-expr int)))))
((c-pointer c-string-list c-string-list*)
(let ((tmp (gensym)))
`(let ((,tmp ,param))
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index f79fda54..42cb0256 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -275,15 +275,14 @@
(eqv? (sub1 limit)
((foreign-lambda* ?type-name ((?type-name x))
"C_return(x);") (sub1 limit))))
- ;; TODO: Should we test for these?
- #;(print "Cannot hold one more than maximum value, " limit "...")
- #;(assert
+ (print "Cannot hold one more than maximum value, " limit "...")
+ (assert
(handle-exceptions exn #t
(begin ((foreign-lambda* ?type-name ((?type-name x))
"C_return(x);") limit)
#f)))
- #;(print "Cannot hold -1 (any fixnum negative value)")
- #;(assert
+ (print "Cannot hold -1 (any fixnum negative value)")
+ (assert
(handle-exceptions exn #t
(begin ((foreign-lambda* ?type-name ((?type-name x))
"C_return(x);") -1)
@@ -307,17 +306,16 @@
(eqv? (- limit)
((foreign-lambda* ?type-name ((?type-name x))
"C_return(x);") (- limit))))
- ;; TODO: Should we check for these?
- #;(print "Cannot hold one more than maximum value " limit "...")
- #;(assert
+ (print "Cannot hold one more than maximum value " limit "...")
+ (assert
(handle-exceptions exn #t
- (begin ((foreign-lambda* integer ((integer x))
+ (begin ((foreign-lambda* ?type-name ((?type-name x))
"C_return(x);") limit)
#f)))
- #;(print "Cannot hold one less than minimum value " (- limit) "...")
- #;(assert
+ (print "Cannot hold one less than minimum value " (- limit) "...")
+ (assert
(handle-exceptions exn #t
- (begin ((foreign-lambda* integer ((integer x))
+ (begin ((foreign-lambda* ?type-name ((?type-name x))
"C_return(x);") (sub1 (- limit)))
#f)))))))
Trap