Merge branch 'bounds' of github.com:mflatt/ChezScheme

original commit: fc9b765ed576903919e09f676612359bbbf2231f

LOG

@@ -807,3 +807,6 @@
 - add current-generate-id and expand-omit-library-invocations, which can be
   useful for avoiding library recompilation and redundant invocation checks
     syntax.ss, record.ss, primdata.ss, misc.ms, system.stex
+- fix bounds checking with an immediate index on immutable vectors,
+  fxvectors, strings, and bytevectors
+    cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms

mats/5_5.ms

@@ -428,17 +428,31 @@
  )
 
 (mat $string-ref-check?
-  (let ([s (make-string 3)] [not-s (make-vector 3)])
+  (let ([s (make-string 3)] [imm-s (string->immutable-string (make-string 3))] [not-s (make-vector 3)])
     (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
       (and
         (not (#%$string-ref-check? not-s i0))
         (not (#%$string-ref-check? s ifalse))
         (not (#%$string-ref-check? s i-1))
+        (not (#%$string-ref-check? imm-s i-1))
+        (#%$string-ref-check? s 0)
+        (#%$string-ref-check? s 1)
+        (#%$string-ref-check? s 2)
+        (#%$string-ref-check? imm-s 0)
+        (#%$string-ref-check? imm-s 1)
+        (#%$string-ref-check? imm-s 2)
         (#%$string-ref-check? s i0)
         (#%$string-ref-check? s i1)
         (#%$string-ref-check? s i2)
+        (#%$string-ref-check? imm-s i0)
+        (#%$string-ref-check? imm-s i1)
+        (#%$string-ref-check? imm-s i2)
+        (not (#%$string-ref-check? s 3))
         (not (#%$string-ref-check? s i3))
-        (not (#%$string-ref-check? s ibig)))))
+        (not (#%$string-ref-check? s ibig))
+        (not (#%$string-ref-check? imm-s 3))
+        (not (#%$string-ref-check? imm-s i3))
+        (not (#%$string-ref-check? imm-s ibig)))))
  )
 
 (mat string-ref

mats/5_6.ms

@@ -38,19 +38,35 @@
  )
 
 (mat $vector-ref-check?
-  (let ([v (make-vector 3)] [not-v (make-fxvector 3)])
+  (let ([v (make-vector 3)] [imm-v (vector->immutable-vector (make-vector 3))] [not-v (make-fxvector 3)])
     (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
       (and
         (not (#%$vector-ref-check? not-v i0))
         (not (#%$vector-ref-check? v ifalse))
+        (not (#%$vector-ref-check? imm-v ifalse))
         (not (#%$vector-ref-check? v i-1))
+        (not (#%$vector-ref-check? imm-v i-1))
+        (#%$vector-ref-check? v 0)
+        (#%$vector-ref-check? v 1)
+        (#%$vector-ref-check? v 2) 
+        (#%$vector-ref-check? imm-v 0)
+        (#%$vector-ref-check? imm-v 1)
+        (#%$vector-ref-check? imm-v 2)
         (#%$vector-ref-check? v i0)
         (#%$vector-ref-check? v i1)
         (#%$vector-ref-check? v i2) 
+        (#%$vector-ref-check? imm-v i0)
+        (#%$vector-ref-check? imm-v i1)
+        (#%$vector-ref-check? imm-v i2)
+        (not (#%$vector-ref-check? v 3))
         (not (#%$vector-ref-check? v i3))
-        (not (#%$vector-ref-check? v ibig)))))
+        (not (#%$vector-ref-check? v ibig))
+        (not (#%$vector-ref-check? imm-v 3))
+        (not (#%$vector-ref-check? imm-v i3))
+        (not (#%$vector-ref-check? imm-v ibig)))))
  )
 
+
 (mat vector-ref
     (eqv? (vector-ref '#(a b c) 0) 'a)
     (eqv? (vector-ref '#(a b c) 1) 'b)
@@ -191,17 +207,31 @@
  )
 
 (mat $fxvector-ref-check?
-  (let ([fv (make-fxvector 3)] [not-fv (make-vector 3)])
+  (let ([fv (make-fxvector 3)] [imm-fv (fxvector->immutable-fxvector (make-fxvector 3))] [not-fv (make-vector 3)])
     (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
       (and
         (not (#%$fxvector-ref-check? not-fv i0))
         (not (#%$fxvector-ref-check? fv ifalse))
         (not (#%$fxvector-ref-check? fv i-1))
+        (not (#%$fxvector-ref-check? imm-fv i-1))
+        (#%$fxvector-ref-check? fv 0)
+        (#%$fxvector-ref-check? fv 1)
+        (#%$fxvector-ref-check? fv 2)
+        (#%$fxvector-ref-check? imm-fv 0)
+        (#%$fxvector-ref-check? imm-fv 1)
+        (#%$fxvector-ref-check? imm-fv 2)
         (#%$fxvector-ref-check? fv i0)
         (#%$fxvector-ref-check? fv i1)
         (#%$fxvector-ref-check? fv i2)
+        (#%$fxvector-ref-check? imm-fv i0)
+        (#%$fxvector-ref-check? imm-fv i1)
+        (#%$fxvector-ref-check? imm-fv i2)
+        (not (#%$fxvector-ref-check? fv 3))
         (not (#%$fxvector-ref-check? fv i3))
-        (not (#%$fxvector-ref-check? fv ibig)))))
+        (not (#%$fxvector-ref-check? fv ibig))
+        (not (#%$fxvector-ref-check? imm-fv 3))
+        (not (#%$fxvector-ref-check? imm-fv i3))
+        (not (#%$fxvector-ref-check? imm-fv ibig)))))
  )
 
 (mat fxvector-ref

mats/bytevector.ms

@@ -203,19 +203,33 @@
 )
 
 (mat $bytevector-ref-check?
-  (let ([bv (make-bytevector 3)] [not-bv (make-fxvector 3)])
+  (let ([bv (make-bytevector 3)] [imm-bv (bytevector->immutable-bytevector (make-bytevector 3))] [not-bv (make-fxvector 3)])
     (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)])
       (and
         (not (#%$bytevector-ref-check? 8 not-bv i0))
         (not (#%$bytevector-ref-check? 8 bv ifalse))
         (not (#%$bytevector-ref-check? 8 bv i-1))
+        (not (#%$bytevector-ref-check? 8 imm-bv i-1))
+        (#%$bytevector-ref-check? 8 bv 0)
+        (#%$bytevector-ref-check? 8 bv 1)
+        (#%$bytevector-ref-check? 8 bv 2)
+        (#%$bytevector-ref-check? 8 imm-bv 0)
+        (#%$bytevector-ref-check? 8 imm-bv 1)
+        (#%$bytevector-ref-check? 8 imm-bv 2)
         (#%$bytevector-ref-check? 8 bv i0)
         (#%$bytevector-ref-check? 8 bv i1)
         (#%$bytevector-ref-check? 8 bv i2)
+        (#%$bytevector-ref-check? 8 imm-bv i0)
+        (#%$bytevector-ref-check? 8 imm-bv i1)
+        (#%$bytevector-ref-check? 8 imm-bv i2)
+        (not (#%$bytevector-ref-check? 8 bv 3))
         (not (#%$bytevector-ref-check? 8 bv i3))
-        (not (#%$bytevector-ref-check? 8 bv ibig)))))
+        (not (#%$bytevector-ref-check? 8 bv ibig))
+        (not (#%$bytevector-ref-check? 8 imm-bv 3))
+        (not (#%$bytevector-ref-check? 8 imm-bv i3))
+        (not (#%$bytevector-ref-check? 8 imm-bv ibig)))))
   (let ([n 128])
-    (let ([bv (make-bytevector n)] [not-bv (make-fxvector n)])
+    (let ([bv (make-bytevector n)] [imm-bv (bytevector->immutable-bytevector (make-bytevector n))] [not-bv (make-fxvector n)])
       (and
         (let ([i 0])
           (and (not (#%$bytevector-ref-check? 8 not-bv i))
@@ -228,30 +242,48 @@
                    (not (#%$bytevector-ref-check? 16 bv i))
                    (not (#%$bytevector-ref-check? 32 bv i))
                    (not (#%$bytevector-ref-check? 64 bv i))
+                   (not (#%$bytevector-ref-check? 8 imm-bv i))
+                   (not (#%$bytevector-ref-check? 16 imm-bv i))
+                   (not (#%$bytevector-ref-check? 32 imm-bv i))
+                   (not (#%$bytevector-ref-check? 64 imm-bv i))
                    (f (fx* i 2)))))
         (let f ([i 0])
           (or (fx= i n)
               (and (#%$bytevector-ref-check? 8 bv i)
                    (if (and (fx= (modulo i 2) 0) (fx<= (fx+ i 2) n))
-                       (#%$bytevector-ref-check? 16 bv i)
+                       (and (#%$bytevector-ref-check? 16 bv i)
-                       (not (#%$bytevector-ref-check? 16 bv i)))
+                            (#%$bytevector-ref-check? 16 imm-bv i))
+                       (not (or (#%$bytevector-ref-check? 16 bv i)
+                                (#%$bytevector-ref-check? 16 imm-bv i))))
                    (if (and (fx= (modulo i 4) 0) (fx<= (fx+ i 4) n))
-                       (#%$bytevector-ref-check? 32 bv i)
+                       (and (#%$bytevector-ref-check? 32 bv i)
-                       (not (#%$bytevector-ref-check? 32 bv i)))
+                            (#%$bytevector-ref-check? 32 imm-bv i))
+                       (not (or (#%$bytevector-ref-check? 32 bv i)
+                                (#%$bytevector-ref-check? 32 imm-bv i))))
                    (if (and (fx= (modulo i 8) 0) (fx<= (fx+ i 8) n))
-                       (#%$bytevector-ref-check? 64 bv i)
+                       (and (#%$bytevector-ref-check? 64 bv i)
-                       (not (#%$bytevector-ref-check? 64 bv i)))
+                            (#%$bytevector-ref-check? 64 imm-bv i))
+                       (not (or (#%$bytevector-ref-check? 64 bv i)
+                                (#%$bytevector-ref-check? 64 imm-bv i))))
                    (f (fx+ i 1)))))
         (let ([i n])
-          (not (#%$bytevector-ref-check? 8 bv i))
+          (and (not (#%$bytevector-ref-check? 8 bv i))
                (not (#%$bytevector-ref-check? 16 bv i))
                (not (#%$bytevector-ref-check? 32 bv i))
-          (not (#%$bytevector-ref-check? 64 bv i)))
+               (not (#%$bytevector-ref-check? 64 bv i))
+               (not (#%$bytevector-ref-check? 8 imm-bv i))
+               (not (#%$bytevector-ref-check? 16 imm-bv i))
+               (not (#%$bytevector-ref-check? 32 imm-bv i))
+               (not (#%$bytevector-ref-check? 64 imm-bv i))))
         (let ([i (+ (most-positive-fixnum) 1)])
-          (not (#%$bytevector-ref-check? 8 bv i))
+          (and (not (#%$bytevector-ref-check? 8 bv i))
                (not (#%$bytevector-ref-check? 16 bv i))
                (not (#%$bytevector-ref-check? 32 bv i))
-          (not (#%$bytevector-ref-check? 64 bv i))))))
+               (not (#%$bytevector-ref-check? 64 bv i))
+               (not (#%$bytevector-ref-check? 8 imm-bv i))
+               (not (#%$bytevector-ref-check? 16 imm-bv i))
+               (not (#%$bytevector-ref-check? 32 imm-bv i))
+               (not (#%$bytevector-ref-check? 64 imm-bv i)))))))
 )
 
 (mat bytevector-s8-ref

s/cpnanopass.ss

@@ -3410,7 +3410,7 @@
                   (%inline logor ,e (immediate ,type))))))
         (define-syntax build-ref-check
           (syntax-rules ()
-            [(_ type-disp maximum-length length-offset type mask)
+            [(_ type-disp maximum-length length-offset type mask immutable-flag)
              (lambda (e-v e-i maybe-e-new)
                ; NB: caller must bind e-v, e-i, and maybe-e-new
                (safe-assert (no-need-to-bind? #t e-v))
@@ -3423,7 +3423,7 @@
                      [(expr->index e-i 1 (constant maximum-length)) =>
                       (lambda (index)
                         (let ([e (%inline u<
-                                   (immediate ,(logor (ash index (constant length-offset)) (constant type)))
+                                   (immediate ,(logor (ash index (constant length-offset)) (constant type) (constant immutable-flag)))
                                    ,t)])
                           (if (and (eqv? (constant type) (constant type-fixnum))
                                    (eqv? (constant mask) (constant mask-fixnum)))
@@ -7573,8 +7573,8 @@
                 [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))]
                 [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)]))))
         (let ()
-          (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector))
+          (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector fxvector-immutable-flag))
-          (define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-mutable-fxvector mask-mutable-fxvector))
+          (define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-mutable-fxvector mask-mutable-fxvector fxvector-immutable-flag))
           (define-inline 2 $fxvector-ref-check?
             [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-ref-check e-fv e-i #f))])
           (define-inline 2 $fxvector-set!-check?
@@ -7619,10 +7619,10 @@
         (let ()
           (define build-string-ref-check
             (lambda (e-s e-i)
-              ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string) e-s e-i #f)))
+              ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string string-immutable-flag) e-s e-i #f)))
           (define build-string-set!-check
             (lambda (e-s e-i)
-              ((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string) e-s e-i #f)))
+              ((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string string-immutable-flag) e-s e-i #f)))
           (define-inline 2 $string-ref-check?
             [(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))])
           (define-inline 2 $string-set!-check?
@@ -7677,8 +7677,8 @@
             (define-inline 3 $string-set-immutable!
               [(e-s) ((build-set-immutable! string-type-disp string-immutable-flag) e-s)])))
         (let ()
-          (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector))
+          (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector vector-immutable-flag))
-          (define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector))
+          (define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector vector-immutable-flag))
           (define-inline 2 $vector-ref-check?
             [(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))])
           (define-inline 2 $vector-set!-check?
@@ -7767,7 +7767,7 @@
                                 (lambda (index)
                                   (%inline u<
                                     (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset))
-                                                  (constant type-bytevector)))
+                                                  (constant type-bytevector) (constant bytevector-immutable-flag)))
                                     ,t))]
                                [else
                                  (build-and