mostly improvements for JIT testing

svn: r1995

collects/tests/mzscheme/basic.ss

@@ -1,6 +1,16 @@
 
 (load-relative "loadtest.ss")
 
+(test "bbb" regexp-replace* "a" "aaa" "b")
+
+(define (test-weird-offset regexp-match regexp-match-positions)
+  (test #f regexp-match "e" (open-input-string ""))
+  (test #f regexp-match "e" (open-input-string "") (expt 2 100))
+  (test #f regexp-match "e" (open-input-string "") (expt 2 100) (expt 2 101))
+  (test '((3 . 4)) regexp-match-positions "e" (open-input-string "eaae") 2 (expt 2 101)))
+(test-weird-offset regexp-match regexp-match-positions)
+
+
 (test '() 'null null)
 (test '() 'null ())
 

collects/tests/mzscheme/contmark.ss

@@ -19,51 +19,75 @@
 (syntax-test #'(with-continuation-mark 1 2 3 4))
 (syntax-test #'(with-continuation-mark 1 2 3 . 4))
 
-(test '(10) 'wcm (with-continuation-mark 'key 10 
+(define (wcm f) (f))
-		   (extract-current-continuation-marks 'key)))
-(test '(#(10 #f)) 'wcm (with-continuation-mark 'key 10 
-			 (continuation-mark-set->list* (current-continuation-marks) '(key no-key))))
-(test '(#(#f 10)) 'wcm (with-continuation-mark 'key 10 
-			 (continuation-mark-set->list* (current-continuation-marks) '(no-key key))))
-(test '(#(nope 10)) 'wcm (with-continuation-mark 'key 10 
-			   (continuation-mark-set->list* (current-continuation-marks) '(no-key key) 'nope)))
 
-(test '(#(10 12)) 'wcm (with-continuation-mark 'key1 10 
+;; Test with an without wrapping `lambda', mainly to
+;;  test JIT interactions.
+(define-syntax wcm-test
+  (syntax-rules (lambda)
+    [(_ expect orig)
+     (begin 
+       (test expect wcm orig)
+       (test expect 'wcm (orig)))]))
+	    
+
+(wcm-test '(10) (lambda ()
+		  (with-continuation-mark 'key 10 
+		    (extract-current-continuation-marks 'key))))
+(wcm-test '(#(10 #f)) (lambda ()
+			(with-continuation-mark 'key 10 
+			  (continuation-mark-set->list* (current-continuation-marks) '(key no-key)))))
+(wcm-test '(#(#f 10)) (lambda ()
+			(with-continuation-mark 'key 10 
+			  (continuation-mark-set->list* (current-continuation-marks) '(no-key key)))))
+(wcm-test '(#(nope 10)) (lambda ()
+			  (with-continuation-mark 'key 10 
+			    (continuation-mark-set->list* (current-continuation-marks) '(no-key key) 'nope))))
+
+(wcm-test '(#(10 12)) (lambda ()
+			(with-continuation-mark 'key1 10 
 			  (with-continuation-mark 'key2 12 
-			   (continuation-mark-set->list* (current-continuation-marks) '(key1 key2)))))
+			    (continuation-mark-set->list* (current-continuation-marks) '(key1 key2))))))
-(test '(#(#f 12) #(10 #f)) 'wcm 
+(wcm-test '(#(#f 12) #(10 #f)) 
+	  (lambda ()
 	    (with-continuation-mark 'key1 10 
 	      (let ([x (with-continuation-mark 'key2 12 
 			 (continuation-mark-set->list* (current-continuation-marks) '(key1 key2)))])
 		(if (void? x)
 		    x
-	      x))))
+		    x)))))
 
-(test '(11) 'wcm (with-continuation-mark 'key 10 
+(wcm-test '(11) (lambda ()
+		  (with-continuation-mark 'key 10 
 		    (with-continuation-mark 'key 11
+		      (extract-current-continuation-marks 'key)))))
+(wcm-test '(9) (lambda () (with-continuation-mark 'key 10 
+			    (with-continuation-mark 'key2 9
+			      (with-continuation-mark 'key 11
+				(extract-current-continuation-marks 'key2))))))
+(wcm-test '() (lambda () (with-continuation-mark 'key 10 
+			   (with-continuation-mark 'key2 9
+			     (with-continuation-mark 'key 11
+			       (extract-current-continuation-marks 'key3))))))
+
+(wcm-test '() (lambda ()
+		(let ([x (with-continuation-mark 'key 10 (list 100))])
 		  (extract-current-continuation-marks 'key))))
-(test '(9) 'wcm (with-continuation-mark 'key 10 
-	     (with-continuation-mark 'key2 9
-	       (with-continuation-mark 'key 11
-		 (extract-current-continuation-marks 'key2)))))
-(test '() 'wcm (with-continuation-mark 'key 10 
-	    (with-continuation-mark 'key2 9
-	      (with-continuation-mark 'key 11
-		(extract-current-continuation-marks 'key3)))))
 
-(test '() 'wcm (let ([x (with-continuation-mark 'key 10 (list 100))])
+(wcm-test '(11) (lambda ()
-		 (extract-current-continuation-marks 'key)))
+		  (with-continuation-mark 'key 11
-
-(test '(11) 'wcm (with-continuation-mark 'key 11
 		    (let ([x (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))])
-		     (extract-current-continuation-marks 'key))))
+		      (extract-current-continuation-marks 'key)))))
 
-(test '((11) (10 11) (11)) 'wcm (with-continuation-mark 'key 11
+(wcm-test '((11) (10 11) (11)) (lambda ()
+				 (with-continuation-mark 'key 11
 				   (list (extract-current-continuation-marks 'key)
 					 (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))
-					(extract-current-continuation-marks 'key))))
+					 (extract-current-continuation-marks 'key)))))
 
-(test '(11) 'wcm-invoke/tail (with-continuation-mark 'x 10
+(wcm-test '(11)
+	  (lambda ()
+	    (with-continuation-mark 'x 10
 	      (invoke-unit
 	       (unit 
 		 (import)
@@ -72,9 +96,11 @@
 		 (with-continuation-mark 'x 11
 		   (continuation-mark-set->list
 		    (current-continuation-marks)
-				     'x))))))
+		    'x)))))))
 
-(test '(11 10) 'wcm-invoke/nontail (with-continuation-mark 'x 10
+(wcm-test '(11 10) 
+	  (lambda ()
+	    (with-continuation-mark 'x 10
 	      (invoke-unit
 	       (unit 
 		 (import)
@@ -84,21 +110,26 @@
 			     (continuation-mark-set->list
 			      (current-continuation-marks)
 			      'x)))
-					l))))
+		 l)))))
 
-(test '(11 10) 'wcm-begin0 (with-continuation-mark 'x 10
+(wcm-test '(11 10) 
+	  (lambda ()
+	    (with-continuation-mark 'x 10
 	      (begin0
 	       (with-continuation-mark 'x 11
 		 (extract-current-continuation-marks 'x))
-			      (+ 2 3))))
+	       (+ 2 3)))))
-(test '(11 10) 'wcm-begin0/const (with-continuation-mark 'x 10
+(wcm-test '(11 10) 
+	  (lambda ()
+	    (with-continuation-mark 'x 10
 	      (begin0
 	       (with-continuation-mark 'x 11
 		 (extract-current-continuation-marks 'x))
-				    'constant)))
+	       'constant))))
 
 ;; full continuation, same thread
-(test '(11 10) 'wcm-begin0 
+(wcm-test '(11 10)
+	  (lambda ()
 	    (let ([k (with-continuation-mark 'x 10
 		       (begin0
 			(with-continuation-mark 'x 11
@@ -106,10 +137,11 @@
 			(+ 2 3)))])
 	      (continuation-mark-set->list 
 	       (continuation-marks k)
-	 'x)))
+	       'x))))
 
 ;; full continuation, another thread
-(test '(11 10) 'wcm-begin0 
+(wcm-test '(11 10)
+	  (lambda ()
 	    (let ([k (with-continuation-mark 'x 10
 		       (begin0
 			(with-continuation-mark 'x 11
@@ -120,10 +152,11 @@
 		 (thread-wait (thread (lambda () 
 					(set! v (continuation-marks k)))))
 		 v)
-	 'x)))
+	       'x))))
 
 ;; escape continuation, same thread
-(test '(11 10) 'wcm-begin0 
+(wcm-test '(11 10)
+	  (lambda ()
 	    (let ([m (with-continuation-mark 'x 10
 		       (begin0
 			(with-continuation-mark 'x 11
@@ -133,10 +166,11 @@
 			       (continuation-marks k))
 			     (+ 17 7))))
 			(+ 2 3)))])
-	(continuation-mark-set->list m 'x)))
+	      (continuation-mark-set->list m 'x))))
 
 ;; escape continuation, another thread => not allowed
-(test #f 'wcm-begin0 
+(wcm-test #f
+	  (lambda ()
 	    (with-continuation-mark 'x 10
 	      (let/ec k 
 		(with-continuation-mark 'x 12
@@ -144,7 +178,7 @@
 		    (thread-wait 
 		     (thread (lambda () 
 			       (set! v (continuation-marks k)))))
-	      v)))))
+		    v))))))
 
 ;; escape continuation, dead
 (err/rt-test (continuation-marks (let/ec k k)) exn:application:mismatch?)

collects/tests/mzscheme/optimize.ss

@@ -9,16 +9,29 @@
 (define maybe-different-depths? #f)
 
 (define (comp=? c1 c2)
-  (let ([s1 (open-output-string)]
+  (let ([s1 (open-output-bytes)]
-	[s2 (open-output-string)])
+	[s2 (open-output-bytes)])
     (write c1 s1)
     (write c2 s2)
-    (let ([t1 (get-output-string s1)]
+    (let ([t1 (get-output-bytes s1)]
-	  [t2 (get-output-string s2)])
+	  [t2 (get-output-bytes s2)]
-      (or (string=? t1 t2)
+	  [skip-byte (+ 2 ; #~
+			1 ; version length
+			(string-length (version))
+			1 ; symtab count
+			1 ; length
+			1 ; CPT_MARSHALLED for top
+			1)])
+      (or (bytes=? t1 t2)
 	  (and maybe-different-depths?
-	       (string=? (substring t1 5 (string-length t1))
+	       (bytes=? (subbytes t1 0 (sub1 skip-byte))
-			 (substring t2 5 (string-length t2))))))))
+			(subbytes t2 0 (sub1 skip-byte)))
+	       (bytes=? (subbytes t1 skip-byte)
+			(subbytes t2 skip-byte)))
+	  (begin
+	    (printf "~s\n~s\n" t1 t2)
+	    #f
+	    )))))
 
 (define test-comp
   (case-lambda
@@ -101,6 +114,10 @@
 	   '(expt 5 (* 5 6)))
 (test-comp 88
 	   '(if (pair? null) 89 88))
+(test-comp '(if _x_ 2 1)
+	   '(if (not _x_) 1 2))
+(test-comp '(if _x_ 2 1)
+	   '(if (not (not (not _x_))) 1 2))
 
 (test-comp '(let ([x 3]) x)
 	   '((lambda (x) x) 3))

collects/tests/mzscheme/syntax.ss

@@ -19,6 +19,7 @@
       (with-handlers ([void (lambda (x) 5)])
 	(with-handlers ((zero? (lambda (x) 'zero)))
 	  (/ 0))))
+
 (error-test #'(with-handlers ()
 	         (/ 0))
 	    exn:fail:contract:divide-by-zero?)
@@ -29,6 +30,7 @@
 			     (boolean? (lambda (x) 'boolean)))
 		 (/ 0))
 	    exn:application:type?)
+
 (syntax-test #'with-handlers)
 (syntax-test #'(with-handlers))
 (syntax-test #'(with-handlers . 1))

collects/tests/mzscheme/testing.ss

@@ -117,6 +117,7 @@ transcript.
     (set! number-of-error-tests (add1 number-of-error-tests))
     (write expr)
     (display "  =e=> ")
+    (flush-output)
     (call/ec (lambda (escape)
 	       (let* ([old-esc-handler (error-escape-handler)]
 		      [old-handler (current-exception-handler)]