suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

prevent 'split' events from being garbage-collected prematurely

Browse Source 
rewrite ormap and andmap to use list-match

fix an error message

svn: r8854
This commit is contained in:
Greg Cooper 2008-03-03 04:45:37 +00:00
parent b4cca0ce2a
commit 766ad478db
3 changed files with 49 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/frtime/lang-ext.ss
View File

@ -620,14 +620,15 @@
;; split : event[a] (a -> b) -> (b -> event[a]) ;; split : event[a] (a -> b) -> (b -> event[a])
(define (split ev fn) (define (split ev fn)
(let* ([ht (make-hash-table 'weak)] (let* ([ht (make-hash-table 'weak)]
[sig (map-e (lambda (e) [sig (for-each-e!
(let/ec k ev
(send-event (lambda (e)
(hash-table-get ht (fn e) (lambda () (k (void)))) (let/ec k
e))) (send-event
ev)]) (hash-table-get ht (fn e) (lambda () (k (void))))
e)))
ht)])
(lambda (x) (lambda (x)
sig
(hash-table-get (hash-table-get
ht x (lambda () ht x (lambda ()
(let ([rtn (event-receiver)]) (let ([rtn (event-receiver)])

2
collects/frtime/mzscheme-core.ss
View File

@ -389,7 +389,7 @@
[(undefined? lst) undefined] [(undefined? lst) undefined]
[(pair? lst) (cf (first lst) (rest lst))] [(pair? lst) (cf (first lst) (rest lst))]
[(empty? lst) (ef)] [(empty? lst) (ef)]
[else (error "list-match: expected a list, got ~a" lst)])) [else (error "list-match: expected a list but got" lst)]))
lst)) lst))
#;(define (frp:append . args) #;(define (frp:append . args)

48
collects/frtime/mzscheme-utils.ss
View File

@ -132,13 +132,33 @@
(syntax-rules () (syntax-rules ()
[(_ test body ...) (if (not test) (begin body ...))])) [(_ test body ...) (if (not test) (begin body ...))]))
(define (ormap proc lst) (define ormap
(and (pair? lst) (case-lambda
(or (proc (car lst)) (ormap proc (cdr lst))))) [(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) (define (andmap proc lst)
(or (null? lst) (list-match
(and (proc (car lst)) (andmap proc (cdr lst))))) lst
(lambda (a d) (and (proc a) (andmap proc d)))
(lambda () #t)))
(define (caar v) (define (caar v)
(car (car v))) (car (car v)))
@ -261,9 +281,21 @@
l l
(lambda (a d) (cons (f a) (map f d))) (lambda (a d) (cons (f a) (map f d)))
(lambda () null))] (lambda () null))]
[(f l1 l2) (if (and (pair? l1) (pair? l2)) [(f l1 l2) (list-match
(cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2))) l1
null)] (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)) [(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))) (cons (apply f (car l) (map car ls)) (apply map f (cdr l) (map cdr ls)))
null)])) null)]))