* felix winkelmann <fe...@call-with-current-continuation.org> [120304 12:09]:
> From: Christian Kellermann <ck...@pestilenz.org>
> Subject: [Chicken-hackers] [PATCH] Raise error on construction of too large
> vectors/blobs
> Date: Sun, 4 Mar 2012 10:36:35 +0100
>
> > Hi,
> >
> > the attached patch raises an error when one tries to create too
> > large vectors or blobs. Before a out of range error message has
> > been raised, which can be a bit confusing (at least to me). Also
> > this patch adjusts the check to the respective srfi-4 maximum values.
>
> Suggestion: fold the exactness-check into ##sys#check-exact-size-limit,
> this saves a CPS procedure call.
Like this?
--
Who can (make) the muddy water (clear)? Let it be still, and it will
gradually become clear. Who can secure the condition of rest? Let
movement go on, and the condition of rest will gradually arise.
-- Lao Tse.
>From 2647fa32cccec8c97a4f093ff5e1611b6692d1f3 Mon Sep 17 00:00:00 2001
From: Christian Kellermann <ck...@pestilenz.org>
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 | 10 ++++++++++
srfi-4.scm | 32 ++++++++++++++++++--------------
tests/library-tests.scm | 27 +++++++++++++++++++++++++++
tests/srfi-4-tests.scm | 37 ++++++++++++++++++++++++++++++++++++-
5 files changed, 103 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..00825e9 100644
--- a/manual/Unit srfi-4
+++ b/manual/Unit srfi-4
@@ -13,6 +13,16 @@ 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
+0x3fffff '''bytes'''. This limits the number of possible vector sizes:
+
+* All byte vectors have a maximum number of entries of 0xffffff
+* All 16 bit vectors have a maximum number of entries of 0x7fffff
+* All 32 bit vectors have a maximum number of entries of 0x3fffff
+* All 64 bit vectors have a maximum number of entries of 0x1fffff
+
=== 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 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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
