checkpoint some bug fixes and efficiency improvements
svn: r9143
This commit is contained in:
Greg Cooper
parent
fc033290da
commit
7e376d7bef
|
|
@ -166,8 +166,9 @@
|
|||
(event-producer2
|
||||
(lambda (emit)
|
||||
(lambda the-args
|
||||
(when (cons? the-args)
|
||||
(emit (first the-args)))))))
|
||||
(if (cons? the-args)
|
||||
(emit (first the-args))
|
||||
(make-events-now empty))))))
|
||||
|
||||
(define (event-producer2 proc . deps)
|
||||
(let* ([result (apply proc->signal (lambda args (make-events-now empty)) deps)]
|
||||
|
|
@ -175,7 +176,8 @@
|
|||
(lambda (val)
|
||||
(let ([old-value (signal-value result)])
|
||||
(make-events-now
|
||||
(if (= (current-logical-time) (event-set-time old-value))
|
||||
(if (and (event-set? old-value)
|
||||
(= (current-logical-time) (event-set-time old-value)))
|
||||
(append (event-set-events old-value) (list val))
|
||||
(list val))))))])
|
||||
(set-signal-thunk! result proc/emit)
|
||||
|
|
@ -327,7 +329,9 @@
|
|||
|
||||
; set-cell! : cell[a] a -> void
|
||||
(define (set-cell! ref beh)
|
||||
(! man (make-external-event (list (list ((signal-thunk ref) #t) beh)))))
|
||||
(if (man?)
|
||||
(iq-enqueue (list ((signal-thunk ref) #t) beh))
|
||||
(! man (make-external-event (list (list ((signal-thunk ref) #t) beh))))))
|
||||
|
||||
|
||||
(define-values (undefined undefined?)
|
||||
|
|
@ -641,7 +645,6 @@
|
|||
b
|
||||
(filter weak-box-value dependents)))))
|
||||
|
||||
|
||||
(define (update0 b)
|
||||
(match b
|
||||
[(and (? signal?)
|
||||
|
|
@ -652,27 +655,13 @@
|
|||
(let ([new-value (call-with-parameterization
|
||||
params
|
||||
thunk)])
|
||||
(if (or (signal:unchanged? b)
|
||||
(not (or (boolean? new-value)
|
||||
(symbol? new-value)
|
||||
(number? new-value)
|
||||
(string? new-value)))
|
||||
(not (eq? value new-value)))
|
||||
(when (or (signal:unchanged? b)
|
||||
(and (not (eq? value new-value))
|
||||
(or (not (event-set? new-value)) (cons? (event-set-events new-value))
|
||||
(not (event-set? value)))))
|
||||
(begin
|
||||
#;(if (signal? new-value)
|
||||
(raise (make-exn:fail
|
||||
"signal from update thunk!!!"
|
||||
(signal-continuation-marks b))))
|
||||
#;(printf "~n[~a]: ~a --> ~a~n" (cond
|
||||
[(signal:switching? b) 'signal:switching]
|
||||
[(signal:compound? b) 'signal:compound]
|
||||
[(signal:unchanged? b) 'signal:unchanged]
|
||||
[else 'signal])
|
||||
value new-value)
|
||||
(set-signal-value! b new-value)
|
||||
(propagate b))
|
||||
#;(parameterize ([print-struct #f])
|
||||
(printf "~a ... ~a (~a)~n" value new-value b))))]
|
||||
(propagate b))))]
|
||||
[_ (void)]))
|
||||
|
||||
(define (update1 b a)
|
||||
|
|
|
|||
|
|
@ -361,7 +361,7 @@
|
|||
[head last]
|
||||
[producer (proc->signal
|
||||
(lambda ()
|
||||
(let* ([now (and (behavior? consumer) (current-inexact-milliseconds))]
|
||||
(let* ([now (and (signal? consumer) (current-inexact-milliseconds))]
|
||||
[ms (value-now ms-b)])
|
||||
(let loop ()
|
||||
(if (or (empty? (mcdr head))
|
||||
|
|
@ -398,7 +398,7 @@
|
|||
[last-time (current-inexact-milliseconds)]
|
||||
[last-val (value-now b)]
|
||||
[last-alarm 0]
|
||||
[producer (proc->signal (lambda () (and (behavior? consumer) accum)))]
|
||||
[producer (proc->signal (lambda () (and (signal? consumer) accum)))]
|
||||
[consumer (proc->signal void b ms-b)])
|
||||
(set-signal-thunk!
|
||||
consumer
|
||||
|
|
@ -627,8 +627,9 @@
|
|||
(send-event
|
||||
(hash-table-get ht (fn e) (lambda () (k (void))))
|
||||
e)))
|
||||
ht)])
|
||||
ht)])
|
||||
(lambda (x)
|
||||
sig
|
||||
(hash-table-get
|
||||
ht x (lambda ()
|
||||
(let ([rtn (event-receiver)])
|
||||
|
|
|
|||
|
|
@ -149,10 +149,15 @@
|
|||
|
||||
|
||||
(define (filter f l)
|
||||
(cond
|
||||
[(empty? l) empty]
|
||||
[(f (first l)) (cons (first l) (filter f (rest l)))]
|
||||
[else (filter f (rest l))]))
|
||||
(list-match
|
||||
l
|
||||
(lambda (a d) (if (f a)
|
||||
(cons a (filter f d))
|
||||
(filter f d)))
|
||||
(lambda () empty)))
|
||||
; [(empty? l) empty]
|
||||
; [(f (first l)) (cons (first l) (filter f (rest l)))]
|
||||
; [else (filter f (rest l))]))
|
||||
|
||||
|
||||
(define (cons? x) (pair? x))
|
||||
|
|
|
|||
|
|
@ -298,31 +298,30 @@
|
|||
(lambda ()
|
||||
(begin0
|
||||
(let/ec esc
|
||||
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(begin0
|
||||
;;(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(proc (lambda (obj)
|
||||
(if (behavior? obj)
|
||||
(begin
|
||||
(case (hash-table-get deps obj 'absent)
|
||||
[(absent) (hash-table-put! deps obj 'new)
|
||||
(register rtn obj)
|
||||
(iq-enqueue rtn)
|
||||
(esc #f)]
|
||||
(let ([o-depth (signal-depth rtn)])
|
||||
(register rtn obj)
|
||||
(when (> (signal-depth rtn) o-depth)
|
||||
(iq-enqueue rtn)
|
||||
(esc #f)))]
|
||||
[(old) (hash-table-put! deps obj 'alive)]
|
||||
[(new) (void)])
|
||||
(value-now obj))
|
||||
obj))))
|
||||
(hash-table-for-each
|
||||
deps
|
||||
(lambda (k v)
|
||||
(case v
|
||||
[(new) (hash-table-put! deps k 'old)
|
||||
#;(printf "reg~n")
|
||||
(register rtn k)]
|
||||
[(alive) (hash-table-put! deps k 'old)]
|
||||
[(old) (hash-table-remove! deps k)
|
||||
#;(printf "unreg~n")
|
||||
(unregister rtn k)])))
|
||||
#;(printf "count = ~a~n" (hash-table-count deps)))))))
|
||||
obj)));)
|
||||
(hash-table-for-each
|
||||
deps
|
||||
(lambda (k v)
|
||||
(case v
|
||||
[(new alive) (hash-table-put! deps k 'old)]
|
||||
[(old) (hash-table-remove! deps k)
|
||||
(unregister rtn k)])))
|
||||
#;(printf "count = ~a~n" (hash-table-count deps))))))))
|
||||
(iq-enqueue rtn)
|
||||
rtn))
|
||||
|
||||
|
|
@ -389,7 +388,7 @@
|
|||
[(undefined? lst) undefined]
|
||||
[(pair? lst) (cf (first lst) (rest lst))]
|
||||
[(empty? lst) (ef)]
|
||||
[else (error "list-match: expected a list but got" lst)]))
|
||||
[else (error "list-match: expected a list, got ~a" lst)]))
|
||||
lst))
|
||||
|
||||
#;(define (frp:append . args)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user