minor relop-length and assertion-violationf improvements

- zero?, fxzero?, positive?, fxpositive?, etc., now go through (a suitably modified) relop-length so that, for example, (zero? (length x)) results in the same code as (null? x). added correctness tests for these and all of the other predicates that go through relop-length. cpnanopass.ss, 5_2.ms - assertion-violationf and friends now show the who, message, and irritants in the original call when who or message is found not to be of the right type. exceptions.ss
gongchengra · Apr 20, 2019 · 9cdc873 · 9cdc873
1 parent 68cdaba
commit 9cdc873
Show file tree

Hide file tree

Showing 4 changed files with 242 additions and 121 deletions.
diff --git a/LOG b/LOG
@@ -1343,3 +1343,13 @@
   the reduction was dropping the possible side effect expressions
   in this case the (newline).
     cp0.ss
+- zero?, fxzero?, positive?, fxpositive?, etc., now go through
+  (a suitably modified) relop-length so that, for example,
+  (zero? (length x)) results in the same code as (null? x).  added
+  correctness tests for these and all of the other predicates that
+  go through relop-length.
+    cpnanopass.ss, 5_2.ms
+- assertion-violationf and friends now show the who, message, and
+  irritants in the original call when who or message is found not to
+  be of the right type.
+    exceptions.ss
diff --git a/mats/5_2.ms b/mats/5_2.ms
@@ -165,6 +165,97 @@
 (mat length
     (= (length '(1 2 3 4 5)) 5)
     (= (length '()) 0)
+    ; check that expand-primitives doesn't generate incorrect code.
+    ; we don't check that it optimizes, however.
+    (let ([ls* (map make-list '(0 1 2 3 4 5 8 9 10 99 100 101 1000))])
+      (define-syntax test1
+        (syntax-rules ()
+          [(_ prim)
+           (let ()
+             (define (f x)
+               (and
+                 (prim (#3%length x))
+                 (prim (#3%length x))))
+             (andmap
+               (lambda (x)
+                 (let ([n (length x)])
+                   (equal?
+                     (f x)
+                     (prim n))))
+               ls*))]))
+      (define-syntax test2
+        (syntax-rules ()
+          [(_ prim)
+           (let ()
+             (define (f x)
+               (and
+                 (prim (#3%length x) 0)
+                 (prim 0 (#3%length x))
+                 (prim (#3%length x) 1)
+                 (prim 1 (#3%length x))
+                 (prim (#3%length x) 4)
+                 (prim 4 (#3%length x))
+                 (prim (#3%length x) 9)
+                 (prim 9 (#3%length x))
+                 (prim (#3%length x) 100)
+                 (prim 100 (#3%length x))))
+             (andmap
+               (lambda (x)
+                 (let ([n (length x)])
+                   (equal?
+                     (f x)
+                     (and
+                       (prim n 0)
+                       (prim 0 n)
+                       (prim n 1)
+                       (prim 1 n)
+                       (prim n 4)
+                       (prim 4 n)
+                       (prim n 9)
+                       (prim 9 n)
+                       (prim n 100)
+                       (prim 100 n)))))
+               ls*))]))
+      (and
+        (test1 zero?)
+        (test1 positive?)
+        (test1 nonnegative?)
+        (test1 negative?)
+        (test1 nonpositive?)
+        (test1 fxzero?)
+        (test1 fxpositive?)
+        (test1 fxnonnegative?)
+        (test1 fxnegative?)
+        (test1 fxnonpositive?)
+        (test2 eq?)
+        (test2 eqv?)
+        (test2 equal?)
+        (test2 <)
+        (test2 <=)
+        (test2 =)
+        (test2 >=)
+        (test2 >)
+        (test2 r6rs:<)
+        (test2 r6rs:<=)
+        (test2 r6rs:=)
+        (test2 r6rs:>=)
+        (test2 r6rs:>)
+        (test2 r6rs:<)
+        (test2 r6rs:<=)
+        (test2 r6rs:=)
+        (test2 r6rs:>=)
+        (test2 r6rs:>)
+        (test2 fx<)
+        (test2 fx<=)
+        (test2 fx=)
+        (test2 fx>=)
+        (test2 fx>)
+        (test2 fx<?)
+        (test2 fx<=?)
+        (test2 fx=?)
+        (test2 fx>=?)
+        (test2 fx>?)
+        (test2 #%$fxu<)))
  )
 
 (mat list-ref