diff --git a/lib/srfi/160/uvprims.stub b/lib/srfi/160/uvprims.stub index 5026a466..20a684c9 100644 --- a/lib/srfi/160/uvprims.stub +++ b/lib/srfi/160/uvprims.stub @@ -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)))) diff --git a/tools/chibi-ffi b/tools/chibi-ffi index d8cd34a1..c3c1987d 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -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)