From ca2b00a9a3f7c5dc764dd2f3ea33ff4d4c09064d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 31 Jul 2006 11:40:07 +0000
Subject: [PATCH] check new optimizations, BEGIN_/END_ESCAPABLE

svn: r3901
---
 .../mzscheme/benchmarks/common/nestedloop.sch |  5 ++--
 .../tests/mzscheme/benchmarks/common/nfa.sch  |  8 ++++---
 .../tests/mzscheme/benchmarks/common/tak.sch  |  2 +-
 collects/tests/mzscheme/optimize.ss           |  5 ++++
 collects/tests/mzscheme/stx.ss                | 12 ++++++----
 collects/tests/mzscheme/thread.ss             | 24 +++++++++++++++++++
 6 files changed, 45 insertions(+), 11 deletions(-)

diff --git a/collects/tests/mzscheme/benchmarks/common/nestedloop.sch b/collects/tests/mzscheme/benchmarks/common/nestedloop.sch
index eb343c8d02..4c65ceed34 100644
--- a/collects/tests/mzscheme/benchmarks/common/nestedloop.sch
+++ b/collects/tests/mzscheme/benchmarks/common/nestedloop.sch
@@ -56,7 +56,8 @@
                                         (loop5 (+ i5 1) result)
                                         (loop6 (+ i6 1) (+ result 1)))))))))))))))
 
-(display (time (loops 18))) (newline)
-(display (time (func-loops 18))) (newline)
+(define cnt 18)
+(display (time (loops cnt))) (newline)
+(display (time (func-loops cnt))) (newline)
 
 
diff --git a/collects/tests/mzscheme/benchmarks/common/nfa.sch b/collects/tests/mzscheme/benchmarks/common/nfa.sch
index 1bbf8dc00c..5f35c0d528 100644
--- a/collects/tests/mzscheme/benchmarks/common/nfa.sch
+++ b/collects/tests/mzscheme/benchmarks/common/nfa.sch
@@ -40,9 +40,11 @@
 
 (time (let ((input (string-append (make-string 133 #\a) "bc")))
         (let loop ((n 10000))
-          (unless (zero? n)
-            (recursive-nfa input)
-            (loop (- n 1))))))
+          (if (zero? n)
+              'done
+              (begin
+                (recursive-nfa input)
+                (loop (- n 1)))))))
 
 
 
diff --git a/collects/tests/mzscheme/benchmarks/common/tak.sch b/collects/tests/mzscheme/benchmarks/common/tak.sch
index e742915c0f..6519c5279e 100644
--- a/collects/tests/mzscheme/benchmarks/common/tak.sch
+++ b/collects/tests/mzscheme/benchmarks/common/tak.sch
@@ -20,6 +20,6 @@
  
 ;;; call: (tak 18 12 6)
  
-(time (tak 18 12 (read)))
+(time (tak 18 12 2))
 
 
diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
index 8873ea658a..008648ac2e 100644
--- a/collects/tests/mzscheme/optimize.ss
+++ b/collects/tests/mzscheme/optimize.ss
@@ -211,6 +211,11 @@
     (un-exact (- (expt 2 30)) 'bitwise-not (sub1 (expt 2 30)))
     (un-exact (- -1 (expt 2 32)) 'bitwise-not (expt 2 32))
 
+    (bin-exact #t 'char=? #\a #\a)
+    (bin-exact #t 'char=? #\u1034 #\u1034)
+    (bin-exact #f 'char=? #\a #\b)
+    (bin-exact #f 'char=? #\u1034 #\a)
+
     (bin-exact 'a 'vector-ref #(a b c) 0)
     (bin-exact 'b 'vector-ref #(a b c) 1)
     (bin-exact 'c 'vector-ref #(a b c) 2)
diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss
index 8967a07006..e08a4805ac 100644
--- a/collects/tests/mzscheme/stx.ss
+++ b/collects/tests/mzscheme/stx.ss
@@ -265,15 +265,14 @@
 (test 10 syntax-property (expand s) 'testing)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Check tracking of primitive expanders
+;; Check tracking of (formerly) primitive expanders
 
 (test '(let) (tree-map syntax-e) (syntax-property (expand #'(let ([x 10]) x)) 'origin))
-(test '(let let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
+(test '(let*-values let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
 (test '(let) (tree-map syntax-e) (syntax-property (expand #'(let loop ([x 10]) x)) 'origin))
 (test '(letrec) (tree-map syntax-e) (syntax-property (expand #'(letrec ([x 10]) x)) 'origin))
 (test '(let*-values) (tree-map syntax-e) (syntax-property (expand #'(let*-values ([(x) 10]) x)) 'origin))
 
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Symbol Keys
 (test null syntax-property-symbol-keys #'a)
@@ -637,7 +636,7 @@
        (lambda (expr)
 	 (let ([e (expand expr)])
 	   (syntax-case e ()
-	     [(lv () beg)
+	     [(lv (bind ...) beg)
 	      (let ([db (syntax-property #'beg 'disappeared-binding)])
 		(syntax-case #'beg ()
 		  [(bg e)
@@ -652,7 +651,10 @@
 				     (bound-identifier=? (car db) (car o))))
 			   db o))]))])))])
   (check-expr #'(let () (letrec-syntaxes+values ([(x) (lambda (stx) #'(quote y))]) () x)))
-  (check-expr #'(let () (define-syntax (x stx) #'(quote y)) x)))
+  (check-expr #'(let-values () (define-syntax (x stx) #'(quote y)) x))
+  (check-expr #'(let-values ([(y) 2]) (define-syntax (x stx) #'(quote y)) x))
+  (check-expr #'(let () (define-syntax (x stx) #'(quote y)) x))
+  (check-expr #'(let ([z 45]) (define-syntax (x stx) #'(quote y)) x)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; protected identifiers
diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss
index a8d7961b34..483853cff1 100644
--- a/collects/tests/mzscheme/thread.ss
+++ b/collects/tests/mzscheme/thread.ss
@@ -1219,6 +1219,30 @@
 		 (thread (lambda () (k null)))
 		 (sync r-ch))))))))
 
+;; --------------------
+;; Check BEGIN_ESCAPABLE:
+
+(let ([try
+       (lambda (break? kill?)
+         (let ([t (parameterize ([current-directory (or (current-load-relative-directory)
+                                                        (current-directory))])
+                    (thread (lambda () 
+                              (with-handlers ([exn:break? void])
+                                (let loop () (directory-list) (loop))) 
+                              (when kill?
+                                (let loop () (sleep 0.01) (loop))))))])
+           (sleep SLEEP-TIME)
+           (when break?
+             (break-thread t)
+             (when kill?
+               (sleep SLEEP-TIME)))
+           (when kill?
+             (kill-thread t))
+           (thread-wait t)))])
+  (try #t #f)
+  (try #f #t)
+  (try #t #t))
+
 ; --------------------
 
 (report-errs)