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

check value domains on uvector-set! ops

Browse source
This commit is contained in:
Alex Shinn 2021-04-16 10:13:37 +09:00
parent d64f159608
commit 487ea21d77
2 changed files with 74 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -138,37 +138,44 @@ void c128vector_set(sexp ctx, double* uv, int i, sexp v) {
(define-c int u1vector-ref (sexp int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u1vector-set! "u1vector_set") (sexp int int)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2 (expt 2 1))))
(define-c signed-char s8vector-ref (s8vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s8vector-set! "s8vector_set") (s8vector int signed-char)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(<= (- (expt 2 7)) arg2 (- (expt 2 7) 1))))
(define-c unsigned-short u16vector-ref (u16vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u16vector-set! "u16vector_set") (u16vector int unsigned-short)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2 (expt 2 16))))
(define-c short s16vector-ref (s16vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s16vector-set! "s16vector_set") (s16vector int short)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(<= (- (expt 2 15)) arg2 (- (expt 2 15) 1))))
(define-c unsigned-int u32vector-ref (u32vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u32vector-set! "u32vector_set") (u32vector int unsigned-int)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2 (expt 2 32))))
(define-c int32_t s32vector-ref (s32vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (s32vector-set! "s32vector_set") (s32vector int int32_t)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(<= (- (expt 2 31)) arg2 (- (expt 2 31) 1))))
(define-c uint64_t u64vector-ref (u64vector int)
(assert (< -1 arg1 (uvector-length arg0))))
(define-c void (u64vector-set! "u64vector_set") (u64vector int uint64_t)
(assert (< -1 arg1 (uvector-length arg0))))
(assert (< -1 arg1 (uvector-length arg0))
(< -1 arg2)))
(define-c int64_t s64vector-ref (s64vector int)
(assert (< -1 arg1 (uvector-length arg0))))

75
tools/chibi-ffi
View file

@ -1263,18 +1263,24 @@
(define (write-scheme->c expr)
(define (write-numeric-arg x)
;; TODO: check when we can assume a fixnum
(if (symbol? x)
(cat "sexp_unbox_fixnum(" x ")")
(cat "sexp_sint_value(" x ")")
(write-scheme->c x)))
(if (pair? expr)
(case (car expr)
((+ - * / %)
(write-scheme->c (cadr expr))
(for-each
(lambda (x)
(cat " " (car expr) " ")
(write-numeric-arg x))
(cddr expr)))
(let ((expr (if (and (null? (cddr expr)) (memq (car expr) '(- /)))
`(,(car expr)
,(if (eq? '- (car expr)) 0 1)
,@(cdr expr))
expr)))
(write-scheme->c (cadr expr))
(for-each
(lambda (x)
(cat " " (car expr) " ")
(write-numeric-arg x))
(cddr expr))))
((< <= == != >= >)
(let lp ((ls (cdr expr)))
(cat "(" (lambda () (write-numeric-arg (car ls))) " " (car expr)
@ -1284,6 +1290,15 @@
((pair? (cddr ls))
(display " && ")
(lp (cdr ls))))))
((expt)
(if (and (integer? (cadr expr))
(integer? (car (cddr expr))))
(write-scheme->c (expt (cadr expr) (car (cddr expr))))
(cat "pow("
(lambda () (write-numeric-arg (cadr expr)))
", "
(lambda () (write-numeric-arg (car (cddr expr))))
")")))
(else
(write (scheme-procedure->c (car expr)))
(display "(")
@ -1296,17 +1311,47 @@
(display ")")))
(write expr)))
(define (extract-irritants expr)
(reverse
(let lp ((args (cdr expr))
(irr '()))
(cond
((null? args) irr)
((identifier? (car args)) (lp (cdr args) (cons (car args) irr)))
((pair? (car args))
;; pass length rather than vector objects to avoid huge error messages
(if (and (memq (caar args)
'(length bytevector-length u8vector-length uvector-length))
(pair? (cdar args))
(identifier? (car (cdar args))))
(lp (cdr args)
;; sexp_length returns sexp, the others int
(cons (if (eq? 'length (caar args))
(car args)
(list 'sexp_make_fixnum (car args)))
irr))
(lp (cdr args) (lp (cdar args) irr))))
(else (lp (cdr args) irr))))))
(define (write-assertions func asserts)
(for-each
(lambda (assert)
(cat " if (!(" (lambda () (write-scheme->c assert)) ")) {\n"
" return sexp_user_exception(ctx, self, \"assertion failed: \" "
(call-with-output-string
(lambda (out)
(write (call-with-output-string
(lambda (out) (write assert out))) out)))
", SEXP_NULL);\n"
" }\n"))
(let ((irr-ls (extract-irritants assert)))
(cat " if (!(" (lambda () (write-scheme->c assert)) ")) {\n"
" return sexp_user_exception_ls(ctx, self, \"assertion failed: \" "
(call-with-output-string
(lambda (out)
(write (call-with-output-string
(lambda (out) (write assert out))) out)))
", " (length irr-ls)
(lambda ()
(for-each
(lambda (irr)
(cat ", ")
(write-scheme->c irr))
irr-ls))
");\n"
" }\n")))
asserts))
(define (scheme-procedure->c name)