From d5290595ecdc82ecc6763aa72e22ff061cd4034d Mon Sep 17 00:00:00 2001 From: LemonBoy 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. Signed-off-by: Peter Bex --- 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