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

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

@ -111,6 +111,12 @@
(define any-nested-reactivity? (define any-nested-reactivity?
(opt-lambda (obj [mem empty]) (opt-lambda (obj [mem empty])
(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 (cond
[(memq obj mem) #f] [(memq obj mem) #f]
[(behavior? obj) #t] [(behavior? obj) #t]
@ -123,9 +129,9 @@
[(name init-k auto-k acc mut immut sup skipped?) (struct-type-info info)] [(name init-k auto-k acc mut immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)]) [(ctor) (struct-type-make-constructor info)])
(ormap (lambda (i) (any-nested-reactivity? (acc obj i) (cons obj mem))) (ormap (lambda (i) (any-nested-reactivity? (acc obj i) (cons obj mem)))
(build-list (+ auto-k init-k) (lambda (x) x))))] (build-list init-k (lambda (x) x))))]
[(vector? obj) (vector-any (lambda (o) (any-nested-reactivity? o (cons obj mem))) obj)] [(vector? obj) (vector-any (lambda (o) (any-nested-reactivity? o (cons obj mem))) obj)]
[else #f]))) [else #f]))))
(define (deep-value-now/update-deps obj deps table) (define (deep-value-now/update-deps obj deps table)
(cond (cond
@ -147,8 +153,7 @@
(cons car-val cdr-val)))] (cons car-val cdr-val)))]
; won't work in the presence of super structs or immutable fields ; won't work in the presence of super structs or immutable fields
[(struct? obj) [(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)] [(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)]
[(ctor) (struct-type-make-constructor info)] [(ctor) (struct-type-make-constructor info)]
[(indices) (build-list init-k identity)] [(indices) (build-list init-k identity)]

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

@ -183,16 +183,28 @@
(values acc (car lst)) (values acc (car lst))
(split-list (append acc (list (car lst))) (cdr 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 (define frp:apply
(lambda (fn . args) (lambda (fn . args)
(if (behavior? args) (if (behavior? fn)
(super-lift (super-lift (lambda (fn) (apply frp:apply/const-fn fn args)) fn)
(lambda (args) (apply frp:apply/const-fn fn args))))
(if (and (list? args) (list? (last-pair args)))
(apply apply fn args)
undefined))
args)
(apply apply fn args))))
#| #|
;; taken from startup.ss ;; taken from startup.ss
(define-syntax frp:case (define-syntax frp:case