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

fix definition of apply in frtime and attempt to fix display of structures with signals

Browse Source 
svn: r8289
This commit is contained in:
Greg Cooper 2008-01-11 03:02:22 +00:00
parent fff894d710
commit 411db7ea43
2 changed files with 42 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -111,21 +111,27 @@
(define any-nested-reactivity?
(opt-lambda (obj [mem empty])
(cond
[(memq obj mem) #f]
[(behavior? obj) #t]
[(cons? obj)
(let ([mem (cons obj mem)])
(or (any-nested-reactivity? (car obj) mem)
(any-nested-reactivity? (cdr obj) mem)))]
[(struct? obj)
(let*-values ([(info skipped) (struct-info obj)]
[(name init-k auto-k acc mut immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)])
(ormap (lambda (i) (any-nested-reactivity? (acc obj i) (cons obj mem)))
(build-list (+ auto-k init-k) (lambda (x) x))))]
[(vector? obj) (vector-any (lambda (o) (any-nested-reactivity? o (cons obj mem))) obj)]
[else #f])))
(with-handlers ((exn:fail?
(lambda (e)
(fprintf
(current-error-port)
"you've encountered a bug in frtime. please send a report to the plt-scheme mailing list.~nexn: ~a~n"
e) #f)))
(cond
[(memq obj mem) #f]
[(behavior? obj) #t]
[(cons? obj)
(let ([mem (cons obj mem)])
(or (any-nested-reactivity? (car obj) mem)
(any-nested-reactivity? (cdr obj) mem)))]
[(struct? obj)
(let*-values ([(info skipped) (struct-info obj)]
[(name init-k auto-k acc mut immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)])
(ormap (lambda (i) (any-nested-reactivity? (acc obj i) (cons obj mem)))
(build-list init-k (lambda (x) x))))]
[(vector? obj) (vector-any (lambda (o) (any-nested-reactivity? o (cons obj mem))) obj)]
[else #f]))))
(define (deep-value-now/update-deps obj deps table)
(cond
@ -147,8 +153,7 @@
(cons car-val cdr-val)))]
; won't work in the presence of super structs or immutable fields
[(struct? obj)
obj
#;(let*-values ([(info skipped) (struct-info obj)]
(let*-values ([(info skipped) (struct-info obj)]
[(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)]
[(indices) (build-list init-k identity)]

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

@ -183,16 +183,28 @@
(values acc (car lst))
(split-list (append acc (list (car lst))) (cdr lst))))
(define (all-but-last lst)
(if (null? (cdr lst))
'()
(cons (car lst) (all-but-last (cdr lst)))))
(define frp:apply/const-fn
(lambda (fn . args)
(let ([first-args (all-but-last args)]
[last-args (first (last-pair args))])
(if (behavior? last-args)
(super-lift
(lambda (last-args)
(apply apply fn (append first-args (list last-args))))
last-args)
(apply apply fn args)))))
(define frp:apply
(lambda (fn . args)
(if (behavior? args)
(super-lift
(lambda (args)
(if (and (list? args) (list? (last-pair args)))
(apply apply fn args)
undefined))
args)
(apply apply fn args))))
(if (behavior? fn)
(super-lift (lambda (fn) (apply frp:apply/const-fn fn args)) fn)
(apply frp:apply/const-fn fn args))))
#|
;; taken from startup.ss
(define-syntax frp:case