From 766ad478dba09b50bf6944dacee9e7928b86aeb5 Mon Sep 17 00:00:00 2001
From: Greg Cooper <greg@cs.brown.edu>
Date: Mon, 3 Mar 2008 04:45:37 +0000
Subject: [PATCH] prevent 'split' events from being garbage-collected
 prematurely

rewrite ormap and andmap to use list-match

fix an error message

svn: r8854
---
 collects/frtime/lang-ext.ss       | 15 +++++-----
 collects/frtime/mzscheme-core.ss  |  2 +-
 collects/frtime/mzscheme-utils.ss | 48 +++++++++++++++++++++++++------
 3 files changed, 49 insertions(+), 16 deletions(-)

diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss
index f514c0723b..be0dfd489b 100644
--- a/collects/frtime/lang-ext.ss
+++ b/collects/frtime/lang-ext.ss
@@ -620,14 +620,15 @@
   ;; split : event[a] (a -> b) -> (b -> event[a])
   (define (split ev fn)
     (let* ([ht (make-hash-table 'weak)]
-           [sig (map-e (lambda (e)
-                         (let/ec k
-                           (send-event
-                            (hash-table-get ht (fn e) (lambda () (k (void))))
-                            e)))
-                       ev)])                             
+           [sig (for-each-e!
+                 ev
+                 (lambda (e)
+                   (let/ec k
+                     (send-event
+                      (hash-table-get ht (fn e) (lambda () (k (void))))
+                      e)))
+                 ht)])                             
       (lambda (x)
-        sig
         (hash-table-get
          ht x (lambda ()
                 (let ([rtn (event-receiver)])
diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss
index cfe3ab1919..a2fd79beef 100644
--- a/collects/frtime/mzscheme-core.ss
+++ b/collects/frtime/mzscheme-core.ss
@@ -389,7 +389,7 @@
          [(undefined? lst) undefined]
          [(pair? lst) (cf (first lst) (rest lst))]
          [(empty? lst) (ef)]
-         [else (error "list-match: expected a list, got ~a" lst)]))
+         [else (error "list-match: expected a list but got" lst)]))
      lst))
   
   #;(define (frp:append . args)
diff --git a/collects/frtime/mzscheme-utils.ss b/collects/frtime/mzscheme-utils.ss
index a877eda6d8..b6bd167ff2 100644
--- a/collects/frtime/mzscheme-utils.ss
+++ b/collects/frtime/mzscheme-utils.ss
@@ -132,13 +132,33 @@
     (syntax-rules ()
       [(_ test body ...) (if (not test) (begin body ...))]))
   
-  (define (ormap proc lst)
-    (and (pair? lst)
-         (or (proc (car lst)) (ormap proc (cdr lst)))))
+  (define ormap
+    (case-lambda
+      [(pred lst) (list-match
+                   lst
+                   (lambda (a d) (or (pred a) (ormap pred d)))
+                   (lambda () #f))]
+      [(pred l1 l2) (list-match
+                     l1
+                     (lambda (a1 d1)
+                       (list-match
+                        l2
+                        (lambda (a2 d2)
+                          (or (pred a1 a2) (ormap pred d1 d2)))
+                        (lambda ()
+                          (error "expected lists of same length, but got" l1 l2))))
+                     (lambda ()
+                       (list-match
+                        l2
+                        (lambda (a d)
+                          (error "expected lists of same length, but got" l1 l2))
+                        (lambda () #f))))]))
   
   (define (andmap proc lst)
-    (or (null? lst)
-        (and (proc (car lst)) (andmap proc (cdr lst)))))
+    (list-match
+     lst
+     (lambda (a d) (and (proc a) (andmap proc d)))
+     (lambda () #t)))
   
   (define (caar v)
     (car (car v)))
@@ -261,9 +281,21 @@
               l
               (lambda (a d) (cons (f a) (map f d)))
               (lambda () null))]
-      [(f l1 l2) (if (and (pair? l1) (pair? l2))
-                     (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2)))
-                     null)]
+      [(f l1 l2) (list-match
+                  l1
+                  (lambda (a1 d1)
+                    (list-match
+                     l2
+                     (lambda (a2 d2) (cons (f a1 a2) (map f d1 d2)))
+                     (lambda () (error "map expected lists of same length but got" l1 l2))))
+                  (lambda ()
+                    (list-match
+                     l2
+                     (lambda (a2 d2) (error "map expected lists of same length but got" l1 l2))
+                     (lambda () null))))
+      #;(if (and (pair? l1) (pair? l2))
+          (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2)))
+          null)]
       [(f l . ls) (if (and (pair? l) (andmap pair? ls))
                       (cons (apply f (car l) (map car ls)) (apply map f (cdr l) (map cdr ls)))
                       null)]))