- cleaned up public version of deep-value-now
- removed ft-qq (obsolete implementation of quasiquote) - removed a bunch of commented-out code svn: r12627
This commit is contained in:
Greg Cooper
parent
daaab83572
commit
6d6d85a8fb
|
|
@ -1,6 +1,5 @@
|
|||
(module frtime-lang-only "mzscheme-utils.ss"
|
||||
(require frtime/lang-ext)
|
||||
(require frtime/ft-qq)
|
||||
(require (as-is:unchecked frtime/frp-core
|
||||
event-set? signal-value))
|
||||
|
||||
|
|
@ -18,5 +17,4 @@
|
|||
|
||||
(provide value-nowable? behaviorof
|
||||
(all-from "mzscheme-utils.ss")
|
||||
(all-from-except frtime/lang-ext lift)
|
||||
(all-from frtime/ft-qq)))
|
||||
(all-from-except frtime/lang-ext lift)))
|
||||
|
|
|
|||
|
|
@ -166,7 +166,7 @@
|
|||
raise raise-exceptions raise-type-error error exit let/ec
|
||||
|
||||
;; no equiv because I haven't completely thought through these
|
||||
lambda quote quasiquote unquote unquote-splicing make-parameter parameterize
|
||||
lambda quote unquote unquote-splicing make-parameter parameterize
|
||||
procedure-arity-includes? dynamic-require)
|
||||
|
||||
(provide #%app #%top #%datum require require-for-syntax provide define)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
(module frtime "mzscheme-utils.ss"
|
||||
(require "lang-ext.ss")
|
||||
(require (all-except "lang-ext.ss" lift deep-value-now))
|
||||
(require "frp-snip.ss")
|
||||
(require "ft-qq.ss")
|
||||
(require (as-is:unchecked "frp-core.ss"
|
||||
event-set? signal-value))
|
||||
|
||||
|
|
@ -18,7 +17,6 @@
|
|||
;(provide-for-syntax (rename frtime/mzscheme-utils syntax->list syntax->list))
|
||||
|
||||
(provide value-nowable? behaviorof
|
||||
(all-from "lang-ext.ss")
|
||||
(all-from "mzscheme-utils.ss")
|
||||
(all-from-except "lang-ext.ss" lift)
|
||||
(all-from "frp-snip.ss")
|
||||
(all-from "ft-qq.ss")))
|
||||
(all-from "frp-snip.ss")))
|
||||
|
|
|
|||
|
|
@ -1,178 +0,0 @@
|
|||
(module ft-qq "mzscheme-core.ss"
|
||||
(require (as-is:unchecked mzscheme define-values define-syntaxes require-for-syntax
|
||||
raise-type-error quote unquote unquote-splicing))
|
||||
;(require-for-syntax frtime/frp)
|
||||
(require-for-syntax syntax/stx)
|
||||
|
||||
|
||||
(define-values (frp:qq-append)
|
||||
(lambda (a b)
|
||||
(if (list? a)
|
||||
(append a b)
|
||||
(raise-type-error 'unquote-splicing "proper list" a))))
|
||||
|
||||
(define-syntaxes (frp:quasiquote)
|
||||
(let ([here (quote-syntax here)] ; id with module bindings, but not lexical
|
||||
[unquote-stx (quote-syntax unquote)]
|
||||
[unquote-splicing-stx (quote-syntax unquote-splicing)])
|
||||
(lambda (in-form)
|
||||
(if (identifier? in-form)
|
||||
(raise-syntax-error #f "bad syntax" in-form))
|
||||
(let-values
|
||||
(((form) (if (stx-pair? (stx-cdr in-form))
|
||||
(if (stx-null? (stx-cdr (stx-cdr in-form)))
|
||||
(stx-car (stx-cdr in-form))
|
||||
(raise-syntax-error #f "bad syntax" in-form))
|
||||
(raise-syntax-error #f "bad syntax" in-form)))
|
||||
((normal)
|
||||
(lambda (x old)
|
||||
(if (eq? x old)
|
||||
(if (stx-null? x)
|
||||
(quote-syntax ())
|
||||
(list (quote-syntax quote) x))
|
||||
x)))
|
||||
((apply-cons)
|
||||
(lambda (a d)
|
||||
(if (stx-null? d)
|
||||
(list (quote-syntax list) a)
|
||||
(if (if (pair? d)
|
||||
(module-identifier=? (quote-syntax list) (car d))
|
||||
#f)
|
||||
(list* (quote-syntax list) a (cdr d))
|
||||
(list (quote-syntax cons) a d))))))
|
||||
(datum->syntax-object
|
||||
here
|
||||
(normal
|
||||
(letrec-values
|
||||
(((qq)
|
||||
(lambda (x level)
|
||||
(let-values
|
||||
(((qq-list)
|
||||
(lambda (x level)
|
||||
(let-values
|
||||
(((old-first) (stx-car x)))
|
||||
(let-values
|
||||
(((old-second) (stx-cdr x)))
|
||||
(let-values
|
||||
(((first) (qq old-first level)))
|
||||
(let-values
|
||||
(((second) (qq old-second level)))
|
||||
(let-values
|
||||
()
|
||||
(if (if (eq? first old-first)
|
||||
(eq? second old-second)
|
||||
#f)
|
||||
x
|
||||
(apply-cons
|
||||
(normal first old-first)
|
||||
(normal second old-second)))))))))))
|
||||
(if (stx-pair? x)
|
||||
(let-values
|
||||
(((first) (stx-car x)))
|
||||
(if (if (if (identifier? first)
|
||||
(module-identifier=? first unquote-stx)
|
||||
#f)
|
||||
(stx-list? x)
|
||||
#f)
|
||||
(let-values
|
||||
(((rest) (stx-cdr x)))
|
||||
(if (let-values
|
||||
(((g35) (not (stx-pair? rest))))
|
||||
(if g35 g35 (not (stx-null? (stx-cdr rest)))))
|
||||
(raise-syntax-error
|
||||
'unquote
|
||||
"expects exactly one expression"
|
||||
in-form
|
||||
x))
|
||||
(if (zero? level)
|
||||
(stx-car rest)
|
||||
(qq-list x (sub1 level))))
|
||||
(if (if (if (identifier? first)
|
||||
(module-identifier=? first (quote-syntax frp:quasiquote))
|
||||
#f)
|
||||
(stx-list? x)
|
||||
#f)
|
||||
(qq-list x (add1 level))
|
||||
(if (if (if (identifier? first)
|
||||
(module-identifier=? first unquote-splicing-stx)
|
||||
#f)
|
||||
(stx-list? x)
|
||||
#f)
|
||||
(raise-syntax-error
|
||||
'unquote-splicing
|
||||
"invalid context within quasiquote"
|
||||
in-form
|
||||
x)
|
||||
(if (if (stx-pair? first)
|
||||
(if (identifier? (stx-car first))
|
||||
(if (module-identifier=? (stx-car first)
|
||||
unquote-splicing-stx)
|
||||
(stx-list? first)
|
||||
#F)
|
||||
#f)
|
||||
#f)
|
||||
(let-values
|
||||
(((rest) (stx-cdr first)))
|
||||
(if (let-values
|
||||
(((g34) (not (stx-pair? rest))))
|
||||
(if g34
|
||||
g34
|
||||
(not (stx-null? (stx-cdr rest)))))
|
||||
(raise-syntax-error
|
||||
'unquote
|
||||
"expects exactly one expression"
|
||||
in-form
|
||||
x))
|
||||
(let-values
|
||||
(((uqsd) (stx-car rest))
|
||||
((old-l) (stx-cdr x))
|
||||
((l) (qq (stx-cdr x) level)))
|
||||
(if (zero? level)
|
||||
(let-values
|
||||
(((l) (normal l old-l)))
|
||||
(let-values
|
||||
()
|
||||
(list (quote-syntax frp:qq-append) uqsd l)))
|
||||
(let-values
|
||||
(((restx) (qq-list rest (sub1 level))))
|
||||
(let-values
|
||||
()
|
||||
(if (if (eq? l old-l)
|
||||
(eq? restx rest)
|
||||
#f)
|
||||
x
|
||||
(apply-cons
|
||||
(apply-cons
|
||||
(quote-syntax (quote unquote-splicing))
|
||||
(normal restx rest))
|
||||
(normal l old-l))))))))
|
||||
(qq-list x level))))))
|
||||
(if (if (syntax? x)
|
||||
(vector? (syntax-e x))
|
||||
#f)
|
||||
(let-values
|
||||
(((l) (vector->list (syntax-e x))))
|
||||
(let-values
|
||||
(((l2) (qq l level)))
|
||||
(let-values
|
||||
()
|
||||
(if (eq? l l2)
|
||||
x
|
||||
(list (quote-syntax list->vector) l2)))))
|
||||
(if (if (syntax? x) (box? (syntax-e x)) #f)
|
||||
(let-values
|
||||
(((v) (unbox (syntax-e x))))
|
||||
(let-values
|
||||
(((qv) (qq v level)))
|
||||
(let-values
|
||||
()
|
||||
(if (eq? v qv)
|
||||
x
|
||||
(list (quote-syntax box) qv)))))
|
||||
x)))))))
|
||||
(qq form 0))
|
||||
form)
|
||||
in-form)))))
|
||||
|
||||
(provide ;(rename frp:qq-append qq-append)
|
||||
(rename frp:quasiquote quasiquote)))
|
||||
|
|
@ -15,9 +15,52 @@
|
|||
(define name
|
||||
(let ([val (parameterize ([snap? #f])
|
||||
expr)])
|
||||
(lambda () (deep-value-now val))))]))
|
||||
(lambda () (deep-value-now val empty))))]))
|
||||
|
||||
(define deep-value-now
|
||||
(define (deep-value-now obj table)
|
||||
(cond
|
||||
[(assq obj table) => second]
|
||||
[(behavior? obj)
|
||||
(deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))]
|
||||
[(cons? obj)
|
||||
(let* ([result (cons #f #f)]
|
||||
[new-table (cons (list obj result) table)]
|
||||
[car-val (deep-value-now (car obj) new-table)]
|
||||
[cdr-val (deep-value-now (cdr obj) new-table)])
|
||||
(if (and (eq? car-val (car obj))
|
||||
(eq? cdr-val (cdr obj)))
|
||||
obj
|
||||
(cons car-val cdr-val)))]
|
||||
; won't work in the presence of super structs or immutable fields
|
||||
[(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)]
|
||||
[(indices) (build-list init-k identity)]
|
||||
[(result) (apply ctor (build-list init-k (lambda (i) #f)))]
|
||||
[(new-table) (cons (list obj result) table)]
|
||||
[(elts) (build-list init-k (lambda (i)
|
||||
(deep-value-now (acc obj i) new-table)))])
|
||||
(if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts)
|
||||
obj
|
||||
(begin
|
||||
(for-each (lambda (i e) (mut! result i e)) indices elts)
|
||||
result)))]
|
||||
[(vector? obj)
|
||||
(let* ([len (vector-length obj)]
|
||||
[indices (build-list len identity)]
|
||||
[result (build-vector len (lambda (_) #f))]
|
||||
[new-table (cons (list obj result) table)]
|
||||
[elts (build-list len (lambda (i)
|
||||
(deep-value-now (vector-ref obj i) new-table)))])
|
||||
(if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts)
|
||||
obj
|
||||
(begin
|
||||
(for-each (lambda (i e) (vector-set! result i e)) indices elts)
|
||||
result)))]
|
||||
[else obj]))
|
||||
|
||||
#;(define deep-value-now
|
||||
(case-lambda
|
||||
[(obj) (deep-value-now obj empty)]
|
||||
[(obj table)
|
||||
|
|
@ -166,7 +209,7 @@
|
|||
(make-events-now
|
||||
(if first-time
|
||||
empty
|
||||
(list (deep-value-now bh))))
|
||||
(list (deep-value-now bh empty))))
|
||||
(set! first-time #f))))
|
||||
b))
|
||||
|
||||
|
|
@ -389,7 +432,7 @@
|
|||
[consumer (proc->signal
|
||||
(lambda ()
|
||||
(let* ([now (current-inexact-milliseconds)]
|
||||
[new (deep-value-now beh)]
|
||||
[new (deep-value-now beh empty)]
|
||||
[ms (value-now ms-b)])
|
||||
(when (not (equal? new (car (mcar last))))
|
||||
(set-mcdr! last (mcons (cons new now)
|
||||
|
|
@ -786,6 +829,7 @@
|
|||
|
||||
|
||||
(provide raise-exceptions
|
||||
deep-value-now
|
||||
nothing
|
||||
nothing?
|
||||
;general-event-processor
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
(module lang frtime/mzscheme-utils
|
||||
(require frtime/lang-ext)
|
||||
(require frtime/ft-qq)
|
||||
(require (as-is:unchecked frtime/frp-core
|
||||
event-set? signal-value))
|
||||
|
||||
|
|
@ -18,5 +17,4 @@
|
|||
|
||||
(provide value-nowable? behaviorof
|
||||
(all-from frtime/mzscheme-utils)
|
||||
(all-from-except frtime/lang-ext lift)
|
||||
(all-from frtime/ft-qq)))
|
||||
(all-from-except frtime/lang-ext lift)))
|
||||
|
|
|
|||
|
|
@ -1,11 +1,9 @@
|
|||
(module mzscheme-core mzscheme
|
||||
;(require (all-except mzscheme provide module if require letrec null?)
|
||||
;mzlib/list)
|
||||
(require-for-syntax frtime/struct mzlib/list)
|
||||
(require mzlib/list
|
||||
frtime/frp-core
|
||||
(only srfi/43/vector-lib vector-any)
|
||||
(only frtime/lang-ext lift new-cell switch ==> changes)
|
||||
(only frtime/lang-ext lift new-cell switch ==> changes deep-value-now)
|
||||
(only mzlib/etc build-vector rec build-list opt-lambda identity))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -23,10 +21,6 @@
|
|||
...
|
||||
expr ...)]))
|
||||
|
||||
;(define-syntax frp:match
|
||||
; (syntax-rules ()
|
||||
; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
|
||||
|
||||
(define (->boolean x)
|
||||
(if x #t #f))
|
||||
|
||||
|
|
@ -42,7 +36,6 @@
|
|||
[(_ test-exp then-exp else-exp undef-exp)
|
||||
(super-lift
|
||||
(lambda (b)
|
||||
;(printf "~n\t******\tIF CONDITION IS ~a~n" b)
|
||||
(cond
|
||||
[(undefined? b) undef-exp]
|
||||
[b then-exp]
|
||||
|
|
@ -93,21 +86,6 @@
|
|||
(map translate-clause (syntax->list #'(clause ...)))])
|
||||
#'(case-lambda
|
||||
new-clause ...))]))
|
||||
#|
|
||||
(define (split-list acc lst)
|
||||
(if (null? (cdr lst))
|
||||
(values acc lst)
|
||||
(split-list (append acc (list (car lst))) (cdr lst))))
|
||||
|
||||
(define (frp:apply fn . args)
|
||||
(let-values ([(first-args rest-args) (split-list () args)])
|
||||
(if (behavior? rest-args)
|
||||
(super-lift
|
||||
(lambda (rest-args)
|
||||
(apply apply fn (append first-args rest-args)))
|
||||
args)
|
||||
(apply apply fn (append first-args rest-args)))))
|
||||
|#
|
||||
|
||||
(define any-nested-reactivity?
|
||||
(opt-lambda (obj [mem empty])
|
||||
|
|
@ -141,7 +119,8 @@
|
|||
[(absent) (hash-table-put! deps obj 'new)]
|
||||
[(old) (hash-table-put! deps obj 'alive)]
|
||||
[(new) (void)])
|
||||
(deep-value-now/update-deps (signal-value obj) deps table)]
|
||||
(deep-value-now/update-deps (signal-value obj) deps
|
||||
(cons (list obj (signal-value obj)) table))]
|
||||
[(cons? obj)
|
||||
(let* ([result (cons #f #f)]
|
||||
[new-table (cons (list obj result) table)]
|
||||
|
|
@ -178,48 +157,9 @@
|
|||
result)))]
|
||||
[else obj]))
|
||||
|
||||
(define (deep-value-now obj table)
|
||||
(cond
|
||||
[(assq obj table) => second]
|
||||
[(behavior? obj)
|
||||
(deep-value-now (signal-value obj) table)]
|
||||
[(cons? obj)
|
||||
(let* ([result (cons #f #f)]
|
||||
[new-table (cons (list obj result) table)]
|
||||
[car-val (deep-value-now (car obj) new-table)]
|
||||
[cdr-val (deep-value-now (cdr obj) new-table)])
|
||||
(if (and (eq? car-val (car obj))
|
||||
(eq? cdr-val (cdr obj)))
|
||||
obj
|
||||
(cons car-val cdr-val)))]
|
||||
; won't work in the presence of super structs or immutable fields
|
||||
[(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)]
|
||||
[(indices) (build-list init-k identity)]
|
||||
[(result) (apply ctor (build-list init-k (lambda (i) #f)))]
|
||||
[(new-table) (cons (list obj result) table)]
|
||||
[(elts) (build-list init-k (lambda (i)
|
||||
(deep-value-now (acc obj i) new-table)))])
|
||||
(if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts)
|
||||
obj
|
||||
(begin
|
||||
(for-each (lambda (i e) (mut! result i e)) indices elts)
|
||||
result)))]
|
||||
[(vector? obj)
|
||||
(let* ([len (vector-length obj)]
|
||||
[indices (build-list len identity)]
|
||||
[result (build-vector len (lambda (_) #f))]
|
||||
[new-table (cons (list obj result) table)]
|
||||
[elts (build-list len (lambda (i)
|
||||
(deep-value-now (vector-ref obj i) new-table)))])
|
||||
(if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts)
|
||||
obj
|
||||
(begin
|
||||
(for-each (lambda (i e) (vector-set! result i e)) indices elts)
|
||||
result)))]
|
||||
[else obj]))
|
||||
(define (public-dvn obj)
|
||||
(do-in-manager-after
|
||||
(deep-value-now obj empty)))
|
||||
|
||||
(define any-spinal-reactivity?
|
||||
(opt-lambda (lst [mem empty])
|
||||
|
|
@ -261,8 +201,7 @@
|
|||
(iq-enqueue rtn))]
|
||||
[(alive) (hash-table-put! deps k 'old)]
|
||||
[(old) (hash-table-remove! deps k)
|
||||
(unregister rtn k)])))
|
||||
#;(printf "count = ~a~n" (hash-table-count deps))))))
|
||||
(unregister rtn k)])))))))
|
||||
(do-in-manager
|
||||
(iq-enqueue rtn))
|
||||
rtn)
|
||||
|
|
@ -284,8 +223,7 @@
|
|||
(register rtn k)]
|
||||
[(alive) (hash-table-put! deps k 'old)]
|
||||
[(old) (hash-table-remove! deps k)
|
||||
(unregister rtn k)])))
|
||||
#;(printf "count = ~a~n" (hash-table-count deps))))))
|
||||
(unregister rtn k)])))))))
|
||||
(do-in-manager
|
||||
(iq-enqueue rtn))
|
||||
rtn))
|
||||
|
|
@ -299,7 +237,6 @@
|
|||
(begin0
|
||||
(let/ec esc
|
||||
(begin0
|
||||
;;(with-handlers ([exn:fail? (lambda (exn) #f)])
|
||||
(proc (lambda (obj)
|
||||
(if (behavior? obj)
|
||||
(begin
|
||||
|
|
@ -320,8 +257,7 @@
|
|||
(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))))))))
|
||||
(unregister rtn k)])))))))))
|
||||
(iq-enqueue rtn)
|
||||
rtn))
|
||||
|
||||
|
|
@ -334,29 +270,14 @@
|
|||
;; CONS
|
||||
|
||||
|
||||
(define (frp:cons f r)
|
||||
(cons f r)
|
||||
#;(lift #f cons f r)
|
||||
#;(if (or (behavior? f) (behavior? r))
|
||||
(procs->signal:compound
|
||||
cons
|
||||
(lambda (p i)
|
||||
(if (zero? i)
|
||||
(lambda (v) (set-car! p v))
|
||||
(lambda (v) (set-cdr! p v))))
|
||||
f r)
|
||||
(cons f r)))
|
||||
(define frp:cons cons)
|
||||
|
||||
(define (make-accessor acc)
|
||||
(lambda (v)
|
||||
(let loop ([v v])
|
||||
(cond
|
||||
[(signal:compound? v) (acc (signal:compound-content v))]
|
||||
[(signal? v) #;(printf "access to ~a in ~a~n" acc
|
||||
(value-now/no-copy v))
|
||||
#;(lift #t acc v)
|
||||
#;(switch ((changes v) . ==> . acc) (acc (value-now v)))
|
||||
(super-lift acc v)]
|
||||
[(signal? v) (super-lift acc v)]
|
||||
[(signal:switching? v) (super-lift
|
||||
(lambda (_)
|
||||
(loop (unbox (signal:switching-current v))))
|
||||
|
|
@ -390,10 +311,7 @@
|
|||
[(empty? lst) (ef)]
|
||||
[else (error "list-match: expected a list, got ~a" lst)]))
|
||||
lst))
|
||||
|
||||
#;(define (frp:append . args)
|
||||
(apply lift #t append args))
|
||||
|
||||
|
||||
(define frp:append
|
||||
(case-lambda
|
||||
[() ()]
|
||||
|
|
@ -401,18 +319,9 @@
|
|||
[(lst1 lst2 . lsts)
|
||||
(list-match lst1
|
||||
(lambda (f r) (cons f (apply frp:append r lst2 lsts)))
|
||||
(lambda () (apply frp:append lst2 lsts)))
|
||||
#;(frp:if (frp:empty? lst1)
|
||||
(apply frp:append lst2 lsts)
|
||||
(frp:cons (frp:car lst1)
|
||||
(apply frp:append (frp:cdr lst1) lst2 lsts)))]))
|
||||
(lambda () (apply frp:append lst2 lsts)))]))
|
||||
|
||||
(define frp:list list
|
||||
#;(lambda elts
|
||||
(frp:if (frp:empty? elts)
|
||||
'()
|
||||
(frp:cons (frp:car elts)
|
||||
(apply frp:list (frp:cdr elts))))))
|
||||
(define frp:list list)
|
||||
|
||||
(define frp:list*
|
||||
(lambda elts
|
||||
|
|
@ -426,7 +335,6 @@
|
|||
(define (frp:list? itm)
|
||||
(if (signal:compound? itm)
|
||||
(let ([ctnt (signal:compound-content itm)])
|
||||
; (let ([ctnt (value-now itm)])
|
||||
(if (cons? ctnt)
|
||||
(frp:list? (cdr ctnt))
|
||||
#f))
|
||||
|
|
@ -442,23 +350,10 @@
|
|||
|
||||
|
||||
(define frp:vector vector)
|
||||
#;(define (frp:vector . args)
|
||||
(if (ormap behavior? args)
|
||||
(apply procs->signal:compound
|
||||
vector
|
||||
(lambda (vec idx)
|
||||
(lambda (x)
|
||||
(vector-set! vec idx x)))
|
||||
args)
|
||||
(apply vector args)))
|
||||
|
||||
(define (frp:vector-ref v i)
|
||||
(cond
|
||||
[(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)
|
||||
#;(switch ((changes v) . ==> . (lambda (vv) (vector-ref vv i)))
|
||||
(vector-ref (value-now v) i)) ;; rewrite as super-lift
|
||||
#;(lift #t vector-ref v i)]
|
||||
#;[(signal:compound? v) (vector-ref (signal:compound-content v) i)]
|
||||
[(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)]
|
||||
[else (lift #t vector-ref v i)]))
|
||||
|
||||
|
||||
|
|
@ -472,16 +367,7 @@
|
|||
args)])
|
||||
(values
|
||||
desc
|
||||
#;(lambda fields
|
||||
(if (ormap behavior? fields)
|
||||
(apply procs->signal:compound
|
||||
ctor
|
||||
(lambda (strct idx)
|
||||
(lambda (val)
|
||||
(mut strct idx val)))
|
||||
fields)
|
||||
(apply ctor fields)))
|
||||
ctor
|
||||
ctor
|
||||
(lambda (v) (if (signal:compound? v)
|
||||
(pred (value-now/no-copy v))
|
||||
(lift #t pred v)))
|
||||
|
|
@ -646,14 +532,13 @@
|
|||
#%top-interaction
|
||||
raise-reactivity
|
||||
raise-list-for-apply
|
||||
deep-value-now
|
||||
(rename public-dvn deep-value-now)
|
||||
any-nested-reactivity?
|
||||
compound-lift
|
||||
list-match
|
||||
(rename frp:if if)
|
||||
(rename frp:lambda lambda)
|
||||
(rename frp:case-lambda case-lambda)
|
||||
;(rename frp:apply apply)
|
||||
(rename frp:letrec letrec)
|
||||
(rename frp:cons cons)
|
||||
(rename frp:car car)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@
|
|||
if
|
||||
lambda
|
||||
case-lambda
|
||||
;apply
|
||||
reverse
|
||||
list-ref
|
||||
require
|
||||
|
|
@ -24,8 +23,6 @@
|
|||
make-struct-field-mutator
|
||||
vector
|
||||
vector-ref
|
||||
quasiquote
|
||||
;qq-append
|
||||
define-struct
|
||||
list
|
||||
list*
|
||||
|
|
@ -33,8 +30,7 @@
|
|||
append
|
||||
and
|
||||
or
|
||||
cond when unless ;case
|
||||
; else =>
|
||||
cond when unless
|
||||
map ormap andmap assoc member)
|
||||
(rename mzscheme mzscheme:if if)
|
||||
(rename "lang-ext.ss" lift lift)
|
||||
|
|
@ -59,11 +55,7 @@
|
|||
(if (lift #t positive? idx)
|
||||
(list-ref (cdr lst) (lift #t sub1 idx))
|
||||
(car lst)))
|
||||
|
||||
;(define (frp:eq? itm1 itm2)
|
||||
; (lift #t eq? itm1 itm2))
|
||||
|
||||
|
||||
|
||||
(define-syntax cond
|
||||
(syntax-rules (else =>)
|
||||
[(_ [else result1 result2 ...])
|
||||
|
|
@ -189,14 +181,7 @@
|
|||
|
||||
(define (cddddr v)
|
||||
(cdr (cdddr v)))
|
||||
|
||||
#|
|
||||
(define-syntax frp:case
|
||||
(syntax-rules ()
|
||||
[(_ expr clause ...)
|
||||
(super-lift (lambda (v) (case v clause ...)) expr)]))
|
||||
|#
|
||||
|
||||
|
||||
(define (split-list acc lst)
|
||||
(if (null? (cdr lst))
|
||||
(values acc (car lst))
|
||||
|
|
@ -215,45 +200,7 @@
|
|||
(lambda (last-args)
|
||||
(apply apply fn (append first-args (cons last-args empty))))
|
||||
last-args))))
|
||||
|
||||
#|
|
||||
;; taken from startup.ss
|
||||
(define-syntax frp:case
|
||||
(lambda (x)
|
||||
(syntax-case x (else)
|
||||
((_ v)
|
||||
(syntax (begin v (cond))))
|
||||
((_ v (else e1 e2 ...))
|
||||
(syntax/loc x (begin v e1 e2 ...)))
|
||||
((_ v ((k ...) e1 e2 ...))
|
||||
(syntax/loc x (if (memv v '(k ...)) (begin e1 e2 ...))))
|
||||
((_ v ((k ...) e1 e2 ...) c1 c2 ...)
|
||||
(syntax/loc x (let ((x v))
|
||||
(if (memv x '(k ...))
|
||||
(begin e1 e2 ...)
|
||||
(frp:case x c1 c2 ...)))))
|
||||
((_ v (bad e1 e2 ...) . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (not a datum sequence)"
|
||||
x
|
||||
(syntax bad)))
|
||||
((_ v clause . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (missing expression after datum sequence)"
|
||||
x
|
||||
(syntax clause)))
|
||||
((_ . v)
|
||||
(not (null? (syntax-e (syntax v))))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
x)))))
|
||||
|
||||
|
||||
|#
|
||||
|
||||
|
||||
(define-syntax frp:case
|
||||
(syntax-rules ()
|
||||
[(_ exp clause ...)
|
||||
|
|
@ -274,10 +221,7 @@
|
|||
|
||||
(define map
|
||||
(case-lambda
|
||||
[(f l) #;(if (pair? l)
|
||||
(cons (f (car l)) (map f (cdr l)))
|
||||
null)
|
||||
(list-match
|
||||
[(f l) (list-match
|
||||
l
|
||||
(lambda (a d) (cons (f a) (map f d)))
|
||||
(lambda () null))]
|
||||
|
|
@ -292,10 +236,7 @@
|
|||
(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)]
|
||||
(lambda () 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)]))
|
||||
|
|
@ -323,7 +264,6 @@
|
|||
(define (dont-optimize x) x)
|
||||
|
||||
(provide cond
|
||||
; else =>
|
||||
and
|
||||
or
|
||||
or-undef
|
||||
|
|
@ -342,7 +282,6 @@
|
|||
cdddr
|
||||
cadddr
|
||||
cddddr
|
||||
;case
|
||||
build-path
|
||||
collection-path
|
||||
|
||||
|
|
@ -357,7 +296,7 @@
|
|||
eq?
|
||||
equal? eqv? < > <= >=
|
||||
add1 cos sin tan symbol->string symbol?
|
||||
number->string string->symbol eof-object? exp expt even? odd? string-append eval ; list-ref
|
||||
number->string string->symbol eof-object? exp expt even? odd? string-append eval
|
||||
sub1 sqrt not number? string string? zero? min max modulo
|
||||
string->number void? rational? char? char-upcase char-ci>=? char-ci<=?
|
||||
string>=? char-upper-case? char-alphabetic?
|
||||
|
|
@ -374,8 +313,7 @@
|
|||
date-minute date-second make-date char-downcase char>=? char<=? char->integer integer->char boolean?
|
||||
integer? quotient remainder positive? negative? inexact->exact exact->inexact
|
||||
make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact?
|
||||
char-whitespace? assq assv memq memv list-tail ;reverse
|
||||
;length
|
||||
char-whitespace? assq assv memq memv list-tail
|
||||
seconds->date
|
||||
expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
|
||||
exn:fail? regexp-match
|
||||
|
|
@ -393,12 +331,8 @@
|
|||
procedure-arity-includes? raise-type-error raise thread
|
||||
current-continuation-marks
|
||||
raise-mismatch-error require-for-syntax define-syntax define-syntaxes syntax-rules syntax-case
|
||||
; set-eventspace
|
||||
;install-errortrace-key
|
||||
(lifted:nonstrict format)
|
||||
print-struct
|
||||
;lambda
|
||||
;case-lambda
|
||||
define
|
||||
let
|
||||
let*
|
||||
|
|
@ -409,6 +343,7 @@
|
|||
begin
|
||||
begin0
|
||||
quote
|
||||
quasiquote
|
||||
unquote
|
||||
unquote-splicing
|
||||
|
||||
|
|
@ -442,8 +377,6 @@
|
|||
|
||||
dont-optimize
|
||||
|
||||
; null
|
||||
; make-struct-field-mutator
|
||||
)
|
||||
|
||||
; from core
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
(module reactive "mzscheme-utils.ss"
|
||||
(require "lang-ext.ss")
|
||||
(require "frp-snip.ss")
|
||||
(require "ft-qq.ss")
|
||||
(require frtime/list)
|
||||
(require frtime/etc)
|
||||
(require (as-is:unchecked "frp-core.ss"
|
||||
|
|
@ -25,5 +24,4 @@
|
|||
(all-from frtime/etc)
|
||||
(all-from "mzscheme-utils.ss")
|
||||
(all-from-except "lang-ext.ss" lift)
|
||||
(all-from "frp-snip.ss")
|
||||
(all-from "ft-qq.ss")))
|
||||
(all-from "frp-snip.ss")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user