>From aaf49735f838abce54d0e34701b1a595b67def38 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 | 27 +++++++++++++++++++++++++++
tests/srfi-4-tests.scm | 37 ++++++++++++++++++++++++++++++++++++-
5 files changed, 111 insertions(+), 17 deletions(-)
diff --git a/library.scm b/library.scm
index e6348b8..cd0dfc2 100644
--- a/library.scm
+++ b/library.scm
@@ -150,6 +150,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:
@@ -1274,13 +1275,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)
@@ -1321,7 +1331,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 0edc563..c8d5304 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -264,3 +264,30 @@
(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 (if (##sys#fudge 3)
+ (make-vector #x100000000000000)
+ (make-vector #x1000000))))))
+(assert (error-occured?
+ (lambda () (make-vector (if (##sys#fudge 3)
+ (make-vector #x100000000000000 123)
+ (make-vector #x1000000 123))))))
+(assert (error-occured?
+ (lambda () (make-vector (if (##sys#fudge 3)
+ (make-blob #x100000000000000)
+ (make-blob #x1000000))))))
+(assert (error-occured?
+ (lambda () (make-vector (if (##sys#fudge 3)
+ (make-vector #x100000000000000 123)
+ (make-vector #x1000000 123))))))
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 435f879..6674da6 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,15 @@
(assert
(every =
'(100 99)
- (,(conc "vector->list") x))))))))
+ (,(conc "vector->list") x)))
+ (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.6