>From 7ebe33e32540324b8c0ffcbbc86cf0618029cf10 Mon Sep 17 00:00:00 2001 From: Christian Kellermann Date: Sun, 4 Mar 2012 10:16:01 +0100 Subject: [PATCH] Raise error on construction of too large vectors/blobs "too large" depends on the C_HEADER_SIZE_MASK bits for library blobs and vectors and decreases with the kind of vector for srfi-4 units. This patch also adds the respective test cases for library and srfi-4 tests. The manual section on the srfi-4 unit has been amended to explain the size limits. --- library.scm | 14 ++++++++++++-- manual/Unit srfi-4 | 18 ++++++++++++++++++ srfi-4.scm | 32 ++++++++++++++++++-------------- tests/library-tests.scm | 33 +++++++++++++++++++++++++++++++++ tests/srfi-4-tests.scm | 39 ++++++++++++++++++++++++++++++++++++++- 5 files changed, 119 insertions(+), 17 deletions(-) diff --git a/library.scm b/library.scm index 6211584..93bf9cf 100644 --- a/library.scm +++ b/library.scm @@ -151,6 +151,7 @@ EOF (define-constant read-line-buffer-initial-size 1024) (define-constant default-parameter-vector-size 16) (define maximal-string-length (foreign-value "C_HEADER_SIZE_MASK" unsigned-long)) +(define maximal-vector-size (foreign-value "C_HEADER_SIZE_MASK" unsigned-long)) ;;; System routines: @@ -1275,13 +1276,22 @@ EOF ;;; Blob: +;;; Helper routine for blobs and vectors: +;;; used in library and srfi-4 +(define (##sys#check-exact-size-limit n limit . loc) + (##sys#check-exact n loc) + (if (and (##core#inline "C_fixnum_lessp" 0 n) + (##core#inline "C_fixnum_greaterp" n limit) ) + (##sys#error loc "size value is not in expected range" n 0 limit) ) ) + + (define (##sys#make-blob size) (let ([bv (##sys#allocate-vector size #t #f #t)]) (##core#inline "C_string_to_bytevector" bv) bv) ) (define (make-blob size) - (##sys#check-exact size 'make-blob) + (##sys#check-exact-size-limit size maximal-vector-size 'make-blob) (##sys#make-blob size) ) (define (blob? x) @@ -1322,7 +1332,7 @@ EOF (define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x)) (define (##sys#make-vector size . fill) - (##sys#check-exact size 'make-vector) + (##sys#check-exact-size-limit size maximal-vector-size 'make-vector) (when (fx< size 0) (##sys#error 'make-vector "size is negative" size)) (##sys#allocate-vector size #f diff --git a/manual/Unit srfi-4 b/manual/Unit srfi-4 index cbd167f..ff573b8 100644 --- a/manual/Unit srfi-4 +++ b/manual/Unit srfi-4 @@ -13,6 +13,24 @@ Homogeneous numeric vector datatypes. Also see the [[http://srfi.schemers.org/s * Constructors allow allocating the storage in non garbage collected memory. * 64-bit integer vectors ({{u64vector}} and {{s64vector}}) are not supported. +=== Size limitations + +SRFI-4 vectors internally are implemented with a maximum length of +0xffffff (on 32bit platforms) or 0xffffffffffffff (on 64bit platforms) +'''bytes'''. This limits the number of possible vector elements: + +* All byte vectors have a maximum number of entries of 0xffffff (32 + bit) / 0xffffffffffffff (64 bit) + +* All 16 bit vectors have a maximum number of entries of 0x7fffff (32 + bit) / 0x7fffffffffffff (64 bit) + +* All 32 bit vectors have a maximum number of entries of 0x3fffff (32 + bit) / 0x3fffffffffffff (64 bit) + +* All 64 bit vectors have a maximum number of entries of 0x1fffff (32 + bit) / 0x1fffffffffffff (64 bit) + === Blob conversions (u8vector->blob U8VECTOR)
diff --git a/srfi-4.scm b/srfi-4.scm index 8b3def2..9ef01fb 100644 --- a/srfi-4.scm +++ b/srfi-4.scm @@ -254,16 +254,16 @@ EOF ;;; Basic constructors: -(let* ([ext-alloc +(let* ((ext-alloc (foreign-lambda* scheme-object ([int bytes]) "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));" "if(buf == NULL) C_return(C_SCHEME_FALSE);" "C_block_header(buf) = C_make_header(C_BYTEVECTOR_TYPE, bytes);" - "C_return(buf);") ] - [ext-free + "C_return(buf);") ) + (ext-free (foreign-lambda* void ([scheme-object bv]) - "C_free((void *)C_block_item(bv, 1));") ] - [alloc + "C_free((void *)C_block_item(bv, 1));") ) + (alloc (lambda (loc len ext?) (if ext? (let ([bv (ext-alloc len)]) @@ -271,7 +271,11 @@ EOF (##sys#error loc "not enough memory - cannot allocate external number vector" len)) ) (let ([bv (##sys#allocate-vector len #t #f #t)]) ; this could be made better... (##core#inline "C_string_to_bytevector" bv) - bv) ) ) ] ) + bv) ) ) ) + (maximum-8bit-entries (foreign-value "C_HEADER_SIZE_MASK" unsigned-long)) + (maximum-16bit-entries (##core#inline "C_fixnum_shift_right" maximum-8bit-entries 1)) + (maximum-32bit-entries (##core#inline "C_fixnum_shift_right" maximum-8bit-entries 2)) + (maximum-64bit-entries (##core#inline "C_fixnum_shift_right" maximum-8bit-entries 3))) (set! release-number-vector (lambda (v) @@ -283,7 +287,7 @@ EOF (set! make-u8vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-u8vector) + (##sys#check-exact-size-limit len maximum-8bit-entries 'make-u8vector) (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -296,7 +300,7 @@ EOF (set! make-s8vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-s8vector) + (##sys#check-exact-size-limit len maximum-8bit-entries 'make-s8vector) (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -309,7 +313,7 @@ EOF (set! make-u16vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-u16vector) + (##sys#check-exact-size-limit len maximum-16bit-entries 'make-u16vector) (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -322,7 +326,7 @@ EOF (set! make-s16vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-s16vector) + (##sys#check-exact-size-limit len maximum-16bit-entries 'make-s16vector) (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -335,7 +339,7 @@ EOF (set! make-u32vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-u32vector) + (##sys#check-exact-size-limit len maximum-32bit-entries 'make-u32vector) (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -348,7 +352,7 @@ EOF (set! make-s32vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-s32vector) + (##sys#check-exact-size-limit len maximum-32bit-entries 'make-s32vector) (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -361,7 +365,7 @@ EOF (set! make-f32vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-f32vector) + (##sys#check-exact-size-limit len maximum-32bit-entries 'make-f32vector) (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?)))) (when (and ext? fin?) (set-finalizer! v ext-free)) (if (not init) @@ -376,7 +380,7 @@ EOF (set! make-f64vector (lambda (len #!optional (init #f) (ext? #f) (fin? #t)) - (##sys#check-exact len 'make-f64vector) + (##sys#check-exact-size-limit len maximum-64bit-entries 'make-f64vector) (let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?)))) diff --git a/tests/library-tests.scm b/tests/library-tests.scm index 7a491a0..19f2226 100644 --- a/tests/library-tests.scm +++ b/tests/library-tests.scm @@ -252,3 +252,36 @@ (assert (= 2 guard-called)) +;;; vector and blob limits + +(define (error-occured? thunk) + (equal? + 'error-occured + (call-with-current-continuation + (lambda (exit) + (with-exception-handler + (lambda (e) (exit 'error-occured)) + thunk))))) + +(assert (error-occured? + (lambda () (make-vector -1)))) + +(assert (error-occured? + (lambda () (make-blob -1)))) + +(assert (error-occured? + (lambda () (if (##sys#fudge 3) + (make-vector #x100000000000000) + (make-vector #x1000000))))) +(assert (error-occured? + (lambda () (if (##sys#fudge 3) + (make-vector #x100000000000000 123) + (make-vector #x1000000 123))))) +(assert (error-occured? + (lambda () (if (##sys#fudge 3) + (make-blob #x100000000000000) + (make-blob #x1000000))))) +(assert (error-occured? + (lambda () (if (##sys#fudge 3) + (make-blob #x100000000000000 123) + (make-blob #x1000000 123))))) diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm index 435f879..9604993 100644 --- a/tests/srfi-4-tests.scm +++ b/tests/srfi-4-tests.scm @@ -3,6 +3,33 @@ (use srfi-1 srfi-4) +(define-for-syntax limits + (if (##sys#fudge 3) + '(( u8 . #x100000000000000) + ( s8 . #x100000000000000) + ( u16 . #x80000000000000) + ( s16 . #x80000000000000) + ( u32 . #x40000000000000) + ( s32 . #x40000000000000) + ( f32 . #x40000000000000) + ( f64 . #x20000000000000)) + '(( u8 . #x1000000) + ( s8 . #x1000000) + ( u16 . #x800000 ) + ( s16 . #x800000 ) + ( u32 . #x400000 ) + ( s32 . #x400000 ) + ( f32 . #x400000 ) + ( f64 . #x200000 )))) + +(define (error-occured? thunk) + (equal? + 'error-occured + (call-with-current-continuation + (lambda (exit) + (with-exception-handler + (lambda (e) (exit 'error-occured)) + thunk))))) (define-syntax test1 (er-macro-transformer @@ -20,7 +47,17 @@ (assert (every = '(100 99) - (,(conc "vector->list") x)))))))) + (,(conc "vector->list") x))) + (assert (error-occured? + (lambda () (,(string->symbol (string-append "make-" name "vector" )) -1)))) + (assert + (error-occured? + (lambda () (,(string->symbol (string-append "make-" name "vector" )) + ,(alist-ref (strip-syntax t) limits))))) ; no initialisation + (assert + (error-occured? + (lambda () (,(string->symbol (string-append "make-" name "vector" )) + ,(alist-ref (strip-syntax t) limits) 1))))))))) ; with initialisation (test1 u8) (test1 u16) -- 1.7.4.1