check value domains on uvector-set! ops

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))))

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))
+         (let ((expr (if (and (null? (cddr expr)) (memq (car expr) '(- /)))
-         (for-each
+                         `(,(car expr)
-          (lambda (x)
+                           ,(if (eq? '- (car expr)) 0 1)
-            (cat " " (car expr) " ")
+                           ,@(cdr expr))
-            (write-numeric-arg x))
+                         expr)))
-          (cddr 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"
+     (let ((irr-ls (extract-irritants assert)))
-          "    return sexp_user_exception(ctx, self, \"assertion failed: \" "
+       (cat "  if (!(" (lambda () (write-scheme->c assert)) ")) {\n"
-          (call-with-output-string
+            "    return sexp_user_exception_ls(ctx, self, \"assertion failed: \" "
-            (lambda (out)
+            (call-with-output-string
-              (write (call-with-output-string
+              (lambda (out)
-                       (lambda (out) (write assert out))) out)))
+                (write (call-with-output-string
-          ", SEXP_NULL);\n"
+                         (lambda (out) (write assert out))) out)))
-          "  }\n"))
+            ", " (length irr-ls)
+            (lambda ()
+              (for-each
+               (lambda (irr)
+                 (cat ", ")
+                 (write-scheme->c irr))
+               irr-ls))
+            ");\n"
+            "  }\n")))
    asserts))
 
 (define (scheme-procedure->c name)