Hello hackers,
I found and fixed two small problems in the srfi-4 module, here's a patch (made
against the chicken-5 branch, it should be easily backported to master if
needed) that also includes some tests.
Cheers,
LemonBoy
>From 61aa693ad23b8490982ef9ac67cfe49264838909 Mon Sep 17 00:00:00 2001
From: LemonBoy <thatle...@gmail.com>
Date: Sat, 29 Jul 2017 09:54:01 +0200
Subject: [PATCH] Minor fixes in the srfi-4 module
* subs64vector used the wrong element length (4 instead of 8)
* Make sure the N parameter given to the make-NNvector is a fixnum, do
not forcibly coerce it to a fixnum before doing so. Raise an error if
the calculated vector length overflows.
---
srfi-4.scm | 47 ++++++++++++++++++++++++-----------------------
tests/srfi-4-tests.scm | 28 ++++++++++++++++++++++++++++
2 files changed, 52 insertions(+), 23 deletions(-)
diff --git a/srfi-4.scm b/srfi-4.scm
index 14c0f080..112837b8 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -80,6 +80,7 @@ EOF
(import scheme chicken)
(import chicken.bitwise
+ chicken.fixnum
chicken.foreign
chicken.gc
chicken.platform
@@ -367,16 +368,18 @@ EOF
(foreign-lambda* void ((scheme-object bv))
"C_free((void *)C_block_item(bv, 1));") )
(alloc
- (lambda (loc len ext?)
- (##sys#check-fixnum len loc)
- (when (fx< len 0) (##sys#error loc "size is negative" len))
- (if ext?
- (let ((bv (ext-alloc len)))
- (or bv
- (##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) ) ) ) )
+ (lambda (loc elem-size elems ext?)
+ (##sys#check-fixnum elems loc)
+ (when (fx< elems 0) (##sys#error loc "size is negative" elems))
+ (let ((len (fx*? elems elem-size)))
+ (unless len (##sys#error "overflow - cannot allocate the required number of elements" elems))
+ (if ext?
+ (let ((bv (ext-alloc len)))
+ (or bv
+ (##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) ) ) ) ))
(set! release-number-vector
(lambda (v)
@@ -386,7 +389,7 @@ EOF
(set! make-u8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
+ (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector 1 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -398,7 +401,7 @@ EOF
(set! make-s8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
+ (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector 1 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -410,7 +413,7 @@ EOF
(set! make-u16vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
+ (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector 2 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -422,7 +425,7 @@ EOF
(set! make-s16vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
+ (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector 2 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -434,7 +437,7 @@ EOF
(set! make-u32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector 4 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -446,7 +449,7 @@ EOF
(set! make-u64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 'u64vector (alloc 'make-u64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
+ (let ((v (##sys#make-structure 'u64vector (alloc 'make-u64vector 8 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -458,7 +461,7 @@ EOF
(set! make-s32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector 4 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -470,7 +473,7 @@ EOF
(set! make-s64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 's64vector (alloc 'make-s64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
+ (let ((v (##sys#make-structure 's64vector (alloc 'make-s64vector 8 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -482,7 +485,7 @@ EOF
(set! make-f32vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector 4 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -496,9 +499,7 @@ EOF
(set! make-f64vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure
- 'f64vector
- (alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
+ (let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector 8 len ext?))))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -779,7 +780,7 @@ EOF
(define (subs8vector v from to) (subnvector v 's8vector 1 from to 'subs8vector))
(define (subs16vector v from to) (subnvector v 's16vector 2 from to 'subs16vector))
(define (subs32vector v from to) (subnvector v 's32vector 4 from to 'subs32vector))
-(define (subs64vector v from to) (subnvector v 's64vector 4 from to 'subs64vector))
+(define (subs64vector v from to) (subnvector v 's64vector 8 from to 'subs64vector))
(define (subf32vector v from to) (subnvector v 'f32vector 4 from to 'subf32vector))
(define (subf64vector v from to) (subnvector v 'f64vector 8 from to 'subf64vector))
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 5f02ae55..a4313ab7 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -30,6 +30,25 @@
(and (eqv? 127 (car result))
(eqv? 99 (cadr result))))))))))
+(define-syntax test-subv
+ (er-macro-transformer
+ (lambda (x r c)
+ (let* ((t (strip-syntax (cadr x)))
+ (make (symbol-append 'make- t 'vector))
+ (subv (symbol-append 'sub t 'vector))
+ (len (symbol-append t 'vector-length)))
+ `(let ((x (,make 10)))
+ (assert (eq? (,len (,subv x 0 5)) 5)))))))
+
+(test-subv u8)
+(test-subv s8)
+(test-subv u16)
+(test-subv s16)
+(test-subv u32)
+(test-subv s32)
+(test-subv u64)
+(test-subv s64)
+
(test1 u8 0 255)
(test1 u16 0 65535)
(test1 u32 0 4294967295)
@@ -129,3 +148,12 @@
(with-output-to-string
(lambda ()
(write-u8vector #u8())))))
+
+; make sure the N parameter is a fixnum
+(assert
+ (handle-exceptions exn #t
+ (make-f64vector 4.0) #f))
+; catch the overflow
+(assert
+ (handle-exceptions exn #t
+ (make-f64vector most-positive-fixnum) #f))
--
2.11.0
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
