Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fix upper bounds checks in u64vectors.

Browse source
This commit is contained in:
Alex Shinn 2021-04-30 14:02:29 +09:00
parent 3c138dc808
commit d11106b2f7
4 changed files with 24 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
lib/srfi/160/test.sld
View file

@ -141,6 +141,9 @@
(test '#u32(1 40 30 20 10) (u32vector-copy vrc1))
(u32vector-reverse-copy! vrc2 1 '#u32(0 10 20 30 40) 1 4)
(test '#u32(1 30 20 10 5) (u32vector-copy vrc2))
(let ((uv (make-u64vector 2 0)))
(u64vector-set! uv 0 10631884467263188874)
(test '#u64(10631884467263188874 0) uv))
)
(test-group "uvectors/conversion"

6
lib/srfi/160/uvprims.stub
View file

@ -151,7 +151,7 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short)
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2 (expt 2 16))))
(<= 0 arg2 (expt 2 16))))
(define-c short s16vector-ref (s16vector int)
(assert (< -1 arg1 (uvector-length arg0))))
@ -163,7 +163,7 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int)
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2 (expt 2 32))))
(<= 0 arg2 (expt 2 32))))
(define-c int32_t s32vector-ref (s32vector int)
(assert (< -1 arg1 (uvector-length arg0))))
@ -175,7 +175,7 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t)
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2)))
(<= 0 arg2)))
(define-c int64_t s64vector-ref (s64vector int)
(assert (< -1 arg1 (uvector-length arg0))))

2
sexp.c
View file

@ -3076,7 +3076,7 @@ sexp sexp_list_to_uvector_op(sexp ctx, sexp self, sexp_sint_t n, sexp etype, sex
#if SEXP_USE_UNIFORM_VECTOR_LITERALS
((sexp_uvector_prefix(et) == 'u') || (sexp_uvector_prefix(et) == 's')) ?
#endif
!(sexp_exact_integerp(tmp) && sexp_sint_value(tmp) >= min
!((min == 0 && sexp_bignump(tmp) ? sexp_bignum_sign(tmp) > 0 : sexp_exact_integerp(tmp) && sexp_sint_value(tmp) >= min)
&& (sexp_sint_value(tmp) < 0 || sexp_uint_value(tmp) <= max))
#if SEXP_USE_UNIFORM_VECTOR_LITERALS
: ((sexp_uvector_prefix(et) == 'c') ? !sexp_numberp(tmp) :

21
tools/chibi-ffi
View file

@ -1261,11 +1261,24 @@
(cat " sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n")))
args))
(define (write-scheme->c expr)
(define (string-has-prefix? str prefix)
(let ((prefix-len (string-length prefix)))
(and (>= (string-length str) prefix-len)
(equal? (substring str 0 prefix-len) prefix))))
(define (write-scheme->c expr . o)
(define (write-numeric-arg x)
;; TODO: check when we can assume a fixnum
(if (symbol? x)
(cat "sexp_sint_value(" x ")")
(let ((func (and (pair? o) (car o)))
(sym-name (symbol->string x)))
(if (and func
(string-has-prefix? sym-name "arg")
(unsigned-int-type?
(type-base
(list-ref (func-c-args func)
(string->number (substring sym-name 3))))))
(cat "sexp_uint_value(" x ")")
(cat "sexp_sint_value(" x ")")))
(write-scheme->c x)))
(if (pair? expr)
(case (car expr)
@ -1337,7 +1350,7 @@
(for-each
(lambda (assert)
(let ((irr-ls (extract-irritants assert)))
(cat " if (!(" (lambda () (write-scheme->c assert)) ")) {\n"
(cat " if (!(" (lambda () (write-scheme->c assert func)) ")) {\n"
" return sexp_user_exception_ls(ctx, self, \"assertion failed: \" "
(call-with-output-string
(lambda (out)