>From 7ebe33e32540324b8c0ffcbbc86cf0618029cf10 Mon Sep 17 00:00:00 2001
From: Christian Kellermann <address@hidden>
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
 
 <procedure>(u8vector->blob U8VECTOR)</procedure><br>
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