From 4179cbfa6374e2a3674bcda6ec26c10c4af3be92 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 14 Apr 2012 20:40:03 -0600 Subject: [PATCH] enforce ranges on all integer types DO NOT merge to 5.3 --- collects/ffi/unsafe.rkt | 14 ++- collects/scribblings/foreign/types.scrbl | 31 ++++-- collects/tests/racket/foreign-test.rktl | 11 +- doc/release-notes/racket/HISTORY.txt | 3 + src/foreign/foreign.c | 136 +++++++++++------------ src/foreign/foreign.rktc | 66 ++++++++++- 6 files changed, 176 insertions(+), 85 deletions(-) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 2957c0ff11..4773809474 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -38,13 +38,23 @@ ;; _byte etc is a convenient name for _uint8 & _sint8 ;; (_byte is unsigned) -(define* _byte _uint8) +(define* _byte (make-ctype _uint8 + (lambda (i) (if (and (exact-integer? i) + (<= -128 i -1)) + (+ i 256) + i)) + (lambda (v) v))) (define* _ubyte _uint8) (define* _sbyte _int8) ;; _word etc is a convenient name for _uint16 & _sint16 ;; (_word is unsigned) -(define* _word _uint16) +(define* _word (make-ctype _uint16 + (lambda (i) (if (and (exact-integer? i) + (<= (- (expt 2 15)) i -1)) + (+ i (expt 2 16)) + i)) + (lambda (v) v))) (define* _uword _uint16) (define* _sword _int16) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 40985f227e..2811a8d8ae 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -105,18 +105,35 @@ The basic integer types at various sizes. The @racketidfont{s} or @racketidfont{u} prefix specifies a signed or an unsigned integer, respectively; the ones with no prefix are signed.} + @defthing*[([_byte ctype?] [_sbyte ctype?] - [_ubyte ctype?] - [_short ctype?] + [_ubyte ctype?])]{ + +The @racket[_sbyte] and @racket[_ubyte] types are aliases +for @racket[_sint8] and @racket[_uint8], respectively. +The @racket[_byte] type is like @racket[_ubyte], but adds +256 to a negative Racket value that would work as a @racket[_sbyte] +(i.e., it casts signed bytes to unsigned bytes).} + + +@defthing*[([_word ctype?] + [_sword ctype?] + [_uword ctype?] + )]{ + +The @racket[_sword] and @racket[_uword] types are aliases +for @racket[_sint16] and @racket[_uint16], respectively. +The @racket[_word] type is like @racket[_uword], but coerces +negative values in the same way as @racket[_byte].} + + +@defthing*[([_short ctype?] [_sshort ctype?] [_ushort ctype?] [_int ctype?] [_sint ctype?] [_uint ctype?] - [_word ctype?] - [_sword ctype?] - [_uword ctype?] [_long ctype?] [_slong ctype?] [_ulong ctype?] @@ -127,14 +144,14 @@ respectively; the ones with no prefix are signed.} [_sintptr ctype?] [_uintptr ctype?])]{ -Aliases for basic integer types. The @racket[_byte] aliases correspond -to @racket[_int8]. The @racket[_short] and @racket[_word] aliases +Aliases for basic integer types. The @racket[_short] aliases correspond to @racket[_int16]. The @racket[_int] aliases correspond to @racket[_int32]. The @racket[_long] aliases correspond to either @racket[_int32] or @racket[_int64], depending on the platform. Similarly, the @racket[_intptr] aliases correspond to either @racket[_int32] or @racket[_int64], depending on the platform.} + @defthing*[([_fixnum ctype?] [_ufixnum ctype?])]{ diff --git a/collects/tests/racket/foreign-test.rktl b/collects/tests/racket/foreign-test.rktl index ecc5589b94..e70481c8ca 100644 --- a/collects/tests/racket/foreign-test.rktl +++ b/collects/tests/racket/foreign-test.rktl @@ -10,6 +10,7 @@ (test #f malloc 0 _int) (test #f malloc _int 0) +;; Check integer-range checking: (let () (define (try-int-boundary N _int _uint) (test (- (expt 2 N)) cast (- (expt 2 N)) _int _int) @@ -20,8 +21,14 @@ (err/rt-test (cast (sub1 (- (expt 2 N))) _int _int)) (err/rt-test (cast -1 _uint _uint)) (err/rt-test (cast (- (expt 2 N)) _uint _uint))) - ;(try-int-boundary 7 _int8 _uint8) - ;(try-int-boundary 15 _int16 _uint16) + (try-int-boundary 7 _int8 _uint8) + (try-int-boundary 7 _sbyte _ubyte) + (test 128 cast -128 _byte _byte) + (test 239 cast -17 _byte _byte) + (try-int-boundary 15 _int16 _uint16) + (try-int-boundary 15 _sword _uword) + (try-int-boundary 15 _short _ushort) + (test (expt 2 15) cast (- (expt 2 15)) _word _word) (try-int-boundary 31 _int32 _uint32) (try-int-boundary 63 _int64 _uint64)) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index b02dfd9ef5..26a1071ec4 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,6 @@ +Version 5.3.0.1 +ffi/unsafe: integer-type bounds consistently checked + Version 5.2.900.1 Add submodules, including module*, module-compiled-submodules Change resolver protocol so that declaration notify is always issued diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 109982fa5f..2330ec23d9 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -472,6 +472,54 @@ MZ_INLINE int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) #endif /* SIXTY_FOUR_BIT_INTEGERS */ +MZ_INLINE static int get_byte_val(Scheme_Object *o, Tsint8 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= -128) && (v <= 127)) { + *_v = v; + return 1; + } + } + return 0; +} + +MZ_INLINE static int get_ubyte_val(Scheme_Object *o, Tuint8 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= 0) && (v <= 255)) { + *_v = v; + return 1; + } + } + return 0; +} + +MZ_INLINE static int get_short_val(Scheme_Object *o, Tsint16 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= -32768) && (v <= 32767)) { + *_v = v; + return 1; + } + } + return 0; +} + +MZ_INLINE static int get_ushort_val(Scheme_Object *o, Tuint16 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= 0) && (v <= 65536)) { + *_v = v; + return 1; + } + } + return 0; +} + /* This is related to the section of scheme.h that defines mzlonglong. */ #ifndef INT64_AS_LONG_LONG #ifdef NO_LONG_LONG_TYPE @@ -545,8 +593,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Type Name: int8 * LibFfi type: ffi_type_sint8 * C type: Tsint8 - * Predicate: SCHEME_INTP() - * Scheme->C: SCHEME_INT_VAL() + * Predicate: get_byte_val(,&aux) + * Scheme->C: -none- (set by the predicate) * S->C offset: 0 * C->Scheme: scheme_make_integer() */ @@ -555,18 +603,18 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Type Name: uint8 * LibFfi type: ffi_type_uint8 * C type: Tuint8 - * Predicate: SCHEME_INTP() - * Scheme->C: SCHEME_UINT_VAL() + * Predicate: get_ubyte_val(,&aux) + * Scheme->C: -none- (set by the predicate) * S->C offset: 0 - * C->Scheme: scheme_make_integer_from_unsigned() + * C->Scheme: scheme_make_integer() */ #define FOREIGN_int16 (4) /* Type Name: int16 * LibFfi type: ffi_type_sint16 * C type: Tsint16 - * Predicate: SCHEME_INTP() - * Scheme->C: SCHEME_INT_VAL() + * Predicate: get_short_val(,&aux) + * Scheme->C: -none- (set by the predicate) * S->C offset: 0 * C->Scheme: scheme_make_integer() */ @@ -575,10 +623,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Type Name: uint16 * LibFfi type: ffi_type_uint16 * C type: Tuint16 - * Predicate: SCHEME_INTP() - * Scheme->C: SCHEME_UINT_VAL() + * Predicate: get_ushort_val(,&aux) + * Scheme->C: -none- (set by the predicate) * S->C offset: 0 - * C->Scheme: scheme_make_integer_from_unsigned() + * C->Scheme: scheme_make_integer() */ /* Treats integers properly: */ @@ -1496,9 +1544,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, } else switch (CTYPE_PRIMLABEL(type)) { case FOREIGN_void: return scheme_void; case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8)); - case FOREIGN_uint8: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint8)); + case FOREIGN_uint8: return scheme_make_integer(REF_CTYPE(Tuint8)); case FOREIGN_int16: return scheme_make_integer(REF_CTYPE(Tsint16)); - case FOREIGN_uint16: return scheme_make_integer_from_unsigned(REF_CTYPE(Tuint16)); + case FOREIGN_uint16: return scheme_make_integer(REF_CTYPE(Tuint16)); case FOREIGN_int32: return scheme_make_realinteger_value(REF_CTYPE(Tsint32)); case FOREIGN_uint32: return scheme_make_realinteger_value_from_unsigned(REF_CTYPE(Tuint32)); case FOREIGN_int64: return scheme_make_integer_value_from_long_long(REF_CTYPE(Tsint64)); @@ -1573,65 +1621,17 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, intptr_t delta, if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type)); break; case FOREIGN_int8: -# ifdef SCHEME_BIG_ENDIAN - if (sizeof(Tsint8)C","int8",0,1,&(val)); - return NULL; /* hush the compiler */ - } + if (!(get_byte_val(val,&(((Tsint8*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int8",0,1,&(val)); + return NULL; case FOREIGN_uint8: -# ifdef SCHEME_BIG_ENDIAN - if (sizeof(Tuint8)C","uint8",0,1,&(val)); - return NULL; /* hush the compiler */ - } + if (!(get_ubyte_val(val,&(((Tuint8*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint8",0,1,&(val)); + return NULL; case FOREIGN_int16: -# ifdef SCHEME_BIG_ENDIAN - if (sizeof(Tsint16)C","int16",0,1,&(val)); - return NULL; /* hush the compiler */ - } + if (!(get_short_val(val,&(((Tsint16*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int16",0,1,&(val)); + return NULL; case FOREIGN_uint16: -# ifdef SCHEME_BIG_ENDIAN - if (sizeof(Tuint16)C","uint16",0,1,&(val)); - return NULL; /* hush the compiler */ - } + if (!(get_ushort_val(val,&(((Tuint16*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","uint16",0,1,&(val)); + return NULL; case FOREIGN_int32: if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int32",0,1,&(val)); return NULL; diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index f91b3a9222..0722199d6f 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -391,6 +391,54 @@ MZ_INLINE int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) } +MZ_INLINE static int get_byte_val(Scheme_Object *o, Tsint8 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= -128) && (v <= 127)) { + *_v = v; + return 1; + } + } + return 0; +} + +MZ_INLINE static int get_ubyte_val(Scheme_Object *o, Tuint8 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= 0) && (v <= 255)) { + *_v = v; + return 1; + } + } + return 0; +} + +MZ_INLINE static int get_short_val(Scheme_Object *o, Tsint16 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= -32768) && (v <= 32767)) { + *_v = v; + return 1; + } + } + return 0; +} + +MZ_INLINE static int get_ushort_val(Scheme_Object *o, Tuint16 *_v) +{ + if (SCHEME_INTP(o)) { + intptr_t v = SCHEME_INT_VAL(o); + if ((v >= 0) && (v <= 65536)) { + *_v = v; + return 1; + } + } + return 0; +} + /* This is related to the section of scheme.h that defines mzlonglong. */ #ifndef INT64_AS_LONG_LONG #ifdef NO_LONG_LONG_TYPE @@ -593,15 +641,21 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) @(defctype 'void 'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void")) -@; libffi primitive types -@; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_ -@(defctype* 'int8 "Tsint8" "INT" "INT" "integer") +@(defctype* 'int8 "Tsint8" + (lambda (x aux) @list{get_byte_val(@x,&@aux)}) #f + "integer") -@(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned") +@(defctype* 'uint8 "Tuint8" + (lambda (x aux) @list{get_ubyte_val(@x,&@aux)}) #f + "integer") -@(defctype* 'int16 "Tsint16" "INT" "INT" "integer") +@(defctype* 'int16 "Tsint16" + (lambda (x aux) @list{get_short_val(@x,&@aux)}) #f + "integer") -@(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned") +@(defctype* 'uint16 "Tuint16" + (lambda (x aux) @list{get_ushort_val(@x,&@aux)}) #f + "integer") /* Treats integers properly: */ @(defctype* 'int32 "Tsint32"