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

- new and improved model for conditionals based on "super-lift"

Browse Source 
- added quasiquote
- made structures memory-efficient
- removed "non-scheduled" dependencies
- split into several modules

svn: r420
This commit is contained in:
Greg Cooper 2005-07-21 18:06:23 +00:00
parent 3a752c0513
commit 0e3a5f01df
18 changed files with 3563 additions and 845 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/frtime/animation.ss
View File

@ -2,7 +2,7 @@
(require (all-except "graphics.ss" make-posn posn-x posn-y make-rgb)
(lifted "graphics.ss" posn-x posn-y make-posn make-rgb)
(all-except (lib "match.ss") match)
(lib "match.ss")
(lib "class.ss")
(lib "list.ss" "frtime")
(lib "etc.ss" "frtime")
@ -73,6 +73,7 @@
(define-struct rrect (ur w h color))
(define-struct curve (xmin xmax ymin ymax fn))
(define-struct polygon (posn-list posn color))
(define-struct solid-polygon (posn-list posn color))
(define (make-circle center r color)
(make-solid-ellipse (make-posn (- (posn-x center) r)
@ -110,7 +111,8 @@
[(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)]
[(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)]
[else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)])]
[($ polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
[($ polygon pts offset color) ((draw-polygon pixmap) pts offset color)]
[($ solid-polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)]
[(? list? x) (draw-list x)]
[(? void?) (void)])
a-los))
@ -136,7 +138,7 @@
(define (valid-posn? v)
(and (posn? v) (number? (posn-x v)) (number? (posn-y v))))
(define seconds~ (/ time-b 1000.0))
(define (key sym)
(key-strokes
@ -213,7 +215,7 @@
(define (wave hz)
(let* ([state (collect-b
(snapshot-e (changes hz) time-b)
(snapshot-e (changes hz) milliseconds)
(make-wave-state (value-now hz) 0)
(lambda (new-freq+time old-state)
(match new-freq+time
@ -224,7 +226,7 @@
h1
(+ o0 (* .002 pi t (- h0 h1))))])])))])
(+ (lift #f wave-state-offset state)
(* time-b pi (lift #f wave-state-hz state) .002))))
(* milliseconds pi (lift #f wave-state-hz state) .002))))
(define (current-and-last-value signal)
(let ([init (value-now signal)])
@ -291,7 +293,8 @@
(make-posn (integral (posn-x p)) (integral (posn-y p))))
(provide
(all-defined-except pixmap window draw-list l d make-circle make-ring make-solid-ellipse
make-rect make-line make-polygon make-graph-string make-wave-state wave-state-hz wave-state-offset)
(lifted make-circle make-ring make-solid-ellipse make-rect make-line make-polygon make-graph-string)
(all-defined-except pixmap window draw-list l d
make-wave-state wave-state-hz wave-state-offset)
#;(lifted make-circle make-ring make-solid-ellipse make-rect make-line make-polygon make-solid-polygon
make-graph-string)
(all-from "graphics.ss")))

9
collects/frtime/demos/analog-clock.ss
View File

@ -28,8 +28,11 @@
(define offset
(hold
(clicks-in-clock . -=> . (value-now (posn- mouse-pos clock-center)))))
(clicks-in-clock
. -=> .
(snapshot (mouse-pos clock-center)
(posn- mouse-pos clock-center)))))
;; Define follow-mouse which is true when the center of the clock
;; should be at the mouse cursor; false when it is at the last
;; click position. Clicking the left button of the mouse
@ -37,7 +40,7 @@
(define follow-mouse?
(hold (merge-e
clicks-in-clock
(left-releases . -=> . false))))
(left-releases . -=> . false)) #f))
;; Define the position of the center and the radius of the clock.
(define clock-center

BIN
collects/frtime/demos/pong.ss
View File

Binary file not shown.

26
collects/frtime/demos/push-pull-ball.ss
View File

@ -8,20 +8,26 @@
(define pos1
(rec pos
(until (make-posn 200 200)
(if (> (posn-diff pos mouse-pos) radius)
(posn+ pos
(posn* (normalize (posn- mouse-pos pos))
(- (posn-diff pos mouse-pos) (sub1 radius))))
pos))))
(delay-by
(let ([brnch (posn+ pos
(posn* (normalize (posn- mouse-pos pos))
(- (posn-diff pos mouse-pos) (sub1 radius))))])
(if (> (posn-diff pos mouse-pos) radius)
brnch
pos))
0))))
(define pos2
(rec pos
(until (make-posn 100 100)
(if (< (posn-diff pos pos1) (* 2 radius))
(posn+ pos
(posn* (normalize (posn- pos1 pos))
(- (posn-diff pos pos1) (add1 (* 2 radius)))))
pos))))
(delay-by
(let ([brnch (posn+ pos
(posn* (normalize (posn- pos1 pos))
(- (posn-diff pos pos1) (add1 (* 2 radius)))))])
(if (< (posn-diff pos pos1) (* 2 radius))
brnch
pos))
0))))
(display-shapes
(list

14
collects/frtime/erl.ss
View File

@ -47,8 +47,8 @@
([exn:fail:network? (lambda (_) (loop (add1 port)))])
(values (tcp-listen port) port))))
(define ip-address
(let*-values
(define ip-address '127.0.0.1
#;(let*-values
([(sub-proc in-p dummy1 dummy2) (subprocess #f #f #f "/bin/hostname" "-i")]
[(ip-address) (read in-p)])
(subprocess-wait sub-proc)
@ -59,8 +59,8 @@
(define my-ip:port
(string->symbol (format "~a:~a" ip-address port)))
(define dns
(dns-find-nameserver))
(define dns #f
#;(dns-find-nameserver))
(define ip-regexp
(regexp "[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?"))
@ -120,8 +120,8 @@
v))))))
(define (receive-help timeout timeout-thunk matcher)
(if (and timeout (negative? timeout))
(timeout-thunk)
;(if (and timeout (negative? timeout))
;(timeout-thunk)
(let* ([start-time (current-milliseconds)]
[mb (hash-table-get mailboxes (tid-lid (self)))]
[val (try-extract matcher (mailbox-old-head mb))])
@ -150,7 +150,7 @@
(loop))
(val)))
(timeout-thunk))))
(val)))))
(val))));)
(define-syntax receive
(syntax-rules (after)

835
collects/frtime/frp-core.ss Normal file
View File

@ -0,0 +1,835 @@
(module frp-core mzscheme
(require (lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
"erl.ss"
"heap.ss")
;;;;;;;;;;;;;
;; Globals ;;
;;;;;;;;;;;;;
(define frtime-inspector (make-inspector))
(print-struct #t)
(define snap? (make-parameter #f))
(define named-dependents (make-hash-table))
(define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004")
;;;;;;;;;;;;;;;;
;; Structures ;;
;;;;;;;;;;;;;;;;
; also models events, where 'value' is all the events that
; haven't yet occurred (more specifically, an event-cons cell whose
; tail is *undefined*)
(define-values (struct:signal
make-signal
signal?
signal-value
signal-dependents
signal-stale?
signal-thunk
signal-depth
signal-continuation-marks
signal-custodians
signal-producers
set-signal-value!
set-signal-dependents!
set-signal-stale?!
set-signal-thunk!
set-signal-depth!
set-signal-continuation-marks!
set-signal-custodians!
set-signal-producers!)
(let*-values ([(field-name-symbols)
(list 'value 'dependents 'stale? 'thunk
'depth 'continuation-marks 'guards 'producers)]
[(desc make-signal signal? acc mut)
(make-struct-type
'signal #f (length field-name-symbols) 0 #f null frtime-inspector
(lambda (fn . args)
(unregister #f fn) ; clear out stale dependencies from previous apps
(let* (; revisit error-reporting for switched behaviors
[ccm (current-continuation-marks)]
[app-fun (lambda (cur-fn)
(let ([res (apply cur-fn args)])
(when (signal? res)
(set-signal-continuation-marks! res ccm))
res))])
(super-lift app-fun fn))))])
(apply values
desc
make-signal
signal?
(append
(build-list (length field-name-symbols)
(lambda (i) (make-struct-field-accessor acc i (list-ref field-name-symbols i))))
(build-list (length field-name-symbols)
(lambda (i) (make-struct-field-mutator mut i (list-ref field-name-symbols i))))))))
(define-syntax signal
(let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk
'depth 'continuation-marks 'guards 'producers)])
(list-immutable
((syntax-local-certifier) #'struct:signal)
((syntax-local-certifier) #'make-signal)
((syntax-local-certifier) #'signal?)
(apply list-immutable
(map
(lambda (fd)
((syntax-local-certifier) (datum->syntax-object
#'here
(string->symbol (format "signal-~a" fd)))))
(reverse field-name-symbols)))
(apply list-immutable
(map
(lambda (fd)
((syntax-local-certifier) (datum->syntax-object
#'here
(string->symbol (format "set-signal-~a!" fd)))))
(reverse field-name-symbols)))
#t)))
(define-struct ft-cust (signal constructed-sigs))
;(define-struct non-scheduled (signal))
(define make-non-scheduled identity)
(define (non-scheduled? x) #f)
(define (non-scheduled-signal x)
(error 'non-scheduled-signal "should never be called"))
(define current-custs
(make-parameter empty))
(define-struct multiple (values) frtime-inspector)
(define-struct event-cons (head tail))
(define econs make-event-cons)
(define efirst event-cons-head)
(define erest event-cons-tail)
(define econs? event-cons?)
(define set-efirst! set-event-cons-head!)
(define set-erest! set-event-cons-tail!)
(define-struct (signal:unchanged signal) () frtime-inspector)
(define-struct (signal:compound signal:unchanged) (content copy) frtime-inspector)
(define-struct (signal:switching signal:unchanged) (current trigger) frtime-inspector)
(define-struct (signal:event signal) () frtime-inspector)
; an external event; contains a list of pairs
; (recip val), where val is passed to recip's thunk
(define-struct external-event (recip-val-pairs))
; update the given signal at the given time
(define-struct alarm (time signal))
;; Simple Structure Combinators
(define (event-receiver)
(event-producer2
(lambda (emit)
(lambda the-args
(when (cons? the-args)
(emit (first the-args)))))))
(define (event-producer2 proc . deps)
(let* ([out (econs undefined undefined)]
[proc/emit (proc
(lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val))])
(apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps)))
(define (build-signal ctor thunk producers)
(let ([ccm (current-continuation-marks)])
(do-in-manager
(let* ([custs (current-custs)]
[cust-sigs (map ft-cust-signal custs)]
[sig (ctor
undefined empty #t thunk
(add1 (apply max 0 (append (map safe-signal-depth producers)
(map safe-signal-depth cust-sigs))))
ccm
custs
(append cust-sigs producers))])
;(printf "~a custodians~n" (length custs))
(when (cons? producers)
(register sig producers))
(when (cons? cust-sigs)
(register (make-non-scheduled sig) cust-sigs))
(for-each (lambda (g) (set-ft-cust-constructed-sigs!
g (cons (make-weak-box sig) (ft-cust-constructed-sigs g))))
custs)
(iq-enqueue sig)
sig))))
(define (proc->signal:switching thunk current-box trigger . producers)
(let ([ccm (current-continuation-marks)])
(do-in-manager
(let* ([custs (current-custs)]
[cust-sigs (map ft-cust-signal custs)]
[sig (make-signal:switching
undefined empty #t thunk
(add1 (apply max 0 (append (map safe-signal-depth producers)
(map safe-signal-depth cust-sigs))))
ccm
custs
(append cust-sigs producers)
current-box
trigger)])
;(printf "~a custodians~n" (length custs))
(when (cons? producers)
(register sig producers))
(when (cons? cust-sigs)
(register (make-non-scheduled sig) cust-sigs))
(for-each (lambda (g) (set-ft-cust-constructed-sigs!
g (cons (make-weak-box sig) (ft-cust-constructed-sigs g))))
custs)
(iq-enqueue sig)
sig))))
(define (proc->signal thunk . producers)
(build-signal make-signal thunk producers))
(define (proc->signal:unchanged thunk . producers)
(build-signal make-signal:unchanged thunk producers))
;; mutate! : compound num -> (any -> ())
(define (procs->signal:compound ctor mutate! . args)
(do-in-manager
(let* ([custs (current-custs)]
[cust-sigs (map ft-cust-signal custs)]
[value (apply ctor (map value-now/no-copy args))]
#;[mutators
(foldl
(lambda (arg idx acc)
(if (signal? arg) ; behavior?
(cons (proc->signal
(let ([m (mutate! value idx)])
(lambda ()
(let ([v (value-now/no-copy arg)])
(m v)
'struct-mutator)))
arg) acc)
acc))
empty args (build-list (length args) identity))]
[sig (make-signal:compound
value
empty
#f
(lambda () ;mutators
(let loop ([i 0] [args args])
(when (cons? args)
((mutate! value i) (value-now/no-copy (car args)))
(loop (add1 i) (cdr args))))
value)
(add1 (apply max 0 (append (map safe-signal-depth args)
(map safe-signal-depth cust-sigs))))
(current-continuation-marks)
custs
(append cust-sigs args)
(apply ctor args)
(lambda () (apply ctor (map value-now args))))])
;(printf "mutators = ~a~n" mutators)
(when (cons? args)
(register sig args))
(when (cons? cust-sigs)
(register (make-non-scheduled sig) cust-sigs))
(for-each (lambda (g) (set-ft-cust-constructed-sigs!
g (cons (make-weak-box sig) (ft-cust-constructed-sigs g))))
custs)
;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig))
sig)))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; Simple Signal Tools ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-event rcvr val)
(! man (make-external-event (list (list rcvr val)))))
(define (send-synchronous-event rcvr val)
(when (man?)
(error 'send-synchronous-event "already in frtime engine (would deadlock)"))
(! man (make-external-event (list (list rcvr val))))
(do-in-manager ()))
(define (send-synchronous-events rcvr-val-pairs)
(when (man?)
(error 'send-synchronous-events "already in frtime engine (would deadlock)"))
(unless (ormap list? rcvr-val-pairs) (error "not list"))
(unless (ormap signal? (map first rcvr-val-pairs)) (error "not signals"))
(! man (make-external-event rcvr-val-pairs))
(do-in-manager ()))
; set-cell! : cell[a] a -> void
(define (set-cell! ref beh)
(! man (make-external-event (list (list ((signal-thunk ref) #t) beh)))))
(define-values (undefined undefined?)
(let-values ([(desc make-undefined undefined? acc mut)
(make-struct-type
'undefined #f 0 0 #f null frtime-inspector
(lambda (fn . args) fn))])
(values (make-undefined) undefined?)))
(define (behavior? v)
(and (signal? v) (not (event-cons? (signal-value v)))))
(define (undef b)
(match b
[(and (? signal?)
(= signal-value value))
(set-signal-stale?! b #f)
(when (not (undefined? value))
(set-signal-value! b undefined)
(propagate b))]
[_ (void)]))
(define (multiple->values v)
(if (multiple? v)
(apply values (multiple-values v))
v))
(define (values->multiple proc)
(call-with-values
proc
(case-lambda
[(v) v]
[vals (make-multiple vals)])))
; value-now : signal[a] -> a
(define (value-now val)
;(multiple->values
(cond
[(signal:compound? val) ((signal:compound-copy val))]
[(signal:switching? val) (value-now (unbox (signal:switching-current val)))]
[(signal? val) (signal-value val)]
[else val]));)
(define (value-now/no-copy val)
;(multiple->values
(cond
[(signal:switching? val) (value-now/no-copy (unbox (signal:switching-current val)))]
[(signal? val) (signal-value val)]
[else val]));)
;; given a list, will return a list of their value-nows that will agree
(define (value-now/sync . sigs)
(do-in-manager-after
(apply values (map value-now sigs))))
#;(define-syntax value-now/sync
(syntax-rules ()
[(_ beh ...)
(begin
(! man (list 'run-thunk/stabalized (self) (lambda () (list (value-now beh) ...))))
(receive [('val v) v]
[('exn e) (raise e)]))]))
(define (extract k evs)
(if (cons? evs)
(let ([ev (first evs)])
(if (or (eq? ev undefined) (undefined? (erest ev)))
(extract k (rest evs))
(begin
(let ([val (efirst (erest ev))])
(set-first! evs (erest ev))
(k val)))))))
(define (kill-signal sig)
;(printf "killing~n")
(for-each
(lambda (prod)
(unregister sig prod))
(signal-producers sig))
(set-signal-thunk! sig (lambda _ 'really-dead))
(set-signal-value! sig 'dead)
(set-signal-dependents! sig empty)
(set-signal-producers! sig empty)
(for-each
(lambda (c)
(set-ft-cust-constructed-sigs!
c
(filter (lambda (wbox)
(cond
[(weak-box-value wbox) => (lambda (v) (not (eq? sig v)))]
[else (begin #;(printf "empty weak box~n") #f)]))
(ft-cust-constructed-sigs c))))
(signal-custodians sig)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Dataflow Graph Maintenance ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (fix-streams streams args)
(if (empty? streams)
empty
(cons
(if (undefined? (first streams))
(let ([stream (signal-value (first args))])
stream
#;(if (undefined? stream)
stream
(if (equal? stream (econs undefined undefined))
stream
(econs undefined stream))))
(first streams))
(fix-streams (rest streams) (rest args)))))
(define (event-forwarder sym evt f+l)
(let ([proc (lambda (emit)
(lambda (the-event)
(for-each (lambda (tid)
(! tid (list 'remote-evt sym the-event))) (rest f+l))))]
[args (list evt)])
(let* ([out (econs undefined undefined)]
[proc/emit (proc
(lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val))]
[streams (map signal-value args)]
[thunk (lambda ()
(when (ormap undefined? streams)
;(fprintf (current-error-port) "had an undefined stream~n")
(set! streams (fix-streams streams args)))
(let loop ()
(extract (lambda (the-event) (proc/emit the-event) (loop))
streams))
(set! streams (map signal-value args))
out)])
(apply proc->signal thunk args))))
(define (safe-signal-depth v)
(cond
[(signal? v) (signal-depth v)]
[(non-scheduled? v) (signal-depth (non-scheduled-signal v))]
[0]))
; *** will have to change significantly to support depth-guided recomputation ***
; Basically, I'll have to check that I'm not introducing a cycle.
; If there is no cycle, then I simply ensure that inf's depth is at least one more than
; sup's. If this requires an increase to inf's depth, then I need to propagate the
; new depth to inf's dependents. Since there are no cycles, this step is guaranteed to
; terminate. When checking for cycles, I should of course stop when I detect a pre-existing
; cycle.
; If there is a cycle, then 'inf' has (and retains) a lower depth than 'sup' (?), which
; indicates the cycle. Importantly, 'propagate' uses the external message queue whenever
; a dependency crosses an inversion of depth.
(define (fix-depths inf sup)
(let help ([inf inf] [sup sup] [mem empty])
(if (memq sup mem)
(send-event exceptions (list (make-exn:fail "tight cycle in dataflow graph" (signal-continuation-marks sup))
sup))
(when (<= (safe-signal-depth inf)
(safe-signal-depth sup))
(set-signal-depth! inf (add1 (safe-signal-depth sup)))
(for-each
(lambda (dep) (help dep inf (cons sup mem)))
(foldl (lambda (wb acc)
(match (weak-box-value wb)
[(and sig (? signal?)) (cons sig acc)]
[(and (? non-scheduled?) (= non-scheduled-signal sig)) (cons sig acc)]
[_ acc]))
empty (signal-dependents inf)))))))
(define-values (iq-enqueue iq-dequeue iq-empty? iq-resort)
(let* ([depth
(lambda (msg)
(if (signal? msg)
(signal-depth msg)
(signal-depth (first msg))))]
[heap (make-heap
(lambda (b1 b2) (< (depth b1) (depth b2)))
eq?)])
(values
(lambda (b) (heap-insert heap b))
(lambda () (heap-pop heap))
(lambda () (heap-empty? heap))
(lambda () (let loop ([elts empty])
(if (heap-empty? heap)
(let loop ([elts elts])
(when (cons? elts)
(heap-insert heap (first elts))
(loop (rest elts))))
(loop (cons (heap-pop heap) elts))))))))
(define-values (alarms-enqueue alarms-dequeue-beh alarms-peak-ms alarms-empty?)
(let ([heap (make-heap (lambda (a b) (< (first a) (first b))) eq?)])
(values (lambda (ms beh) (heap-insert heap (list ms (make-weak-box beh))))
(lambda () (match (heap-pop heap) [(_ beh) (weak-box-value beh)]))
(lambda () (match (heap-peak heap) [(ms _) ms]))
(lambda () (heap-empty? heap)))))
(define (schedule-alarm ms beh)
(when (> ms 1073741824)
(set! ms (- ms 2147483647)))
(if (eq? (self) man)
(alarms-enqueue ms beh)
(! man (make-alarm ms beh))))
;;;;;;;;;;;;;;;;;;;;;
;; Manager Helpers ;;
;;;;;;;;;;;;;;;;;;;;;
(define man?
(opt-lambda ([v (self)])
(eq? v man)))
(define-syntax do-in-manager
(syntax-rules ()
[(_ expr ...)
(if (man?)
(begin expr ...)
(begin
(! man (list 'run-thunk (self) (let ([custs (current-custs)])
(lambda ()
(parameterize ([current-custs custs])
expr ...)))))
(receive [('vals . vs) (apply values vs)]
[('exn e) (raise e)])))]))
(define-syntax do-in-manager-after
(syntax-rules ()
[(_ expr ...)
(if (man?)
(begin expr ...)
(begin
(! man (list 'run-thunk/stabilized (self)
(let ([custs (current-custs)])
(lambda ()
(parameterize ([current-custs custs])
expr ...)))))
(receive [('vals . vs) (apply values vs)]
[('exn e) (raise e)])))]))
(define (register inf sup)
(do-in-manager
(match sup
[(and (? signal?)
(= signal-dependents dependents))
(set-signal-dependents!
sup
(cons (make-weak-box inf) dependents))
(fix-depths inf sup)]
[(? list?) (for-each (lambda (sup1) (register inf sup1)) sup)]
[_ (void)])
inf))
(define (unregister inf sup)
(do-in-manager
(match sup
[(and (? signal?)
(= signal-dependents dependents))
(set-signal-dependents!
sup
(filter (lambda (a)
(let ([v (weak-box-value a)])
(nor (eq? v inf)
(eq? v #f))))
dependents))]
[_ (void)])))
(define (super-lift fun bhvr)
(if (behavior? bhvr)
(do-in-manager
(let* ([cust (make-ft-cust (void) empty)]
[custs (cons cust (current-custs))]
[pfun (lambda (b)
(parameterize ([current-custs custs])
(fun b)))]
[current (box undefined)])
(letrec ([custodian-signal
(proc->signal:unchanged
(lambda ()
(for-each kill-signal (filter identity (map weak-box-value (ft-cust-constructed-sigs cust))))
(unregister rtn (unbox current))
(set-box! current (pfun (value-now/no-copy bhvr)))
(register rtn (unbox current))
;; keep rtn's producers up-to-date
(set-car! (signal-producers rtn) (unbox current))
(iq-resort)
'custodian)
bhvr)]
[rtn (proc->signal:switching
(lambda () custodian-signal (value-now/no-copy (unbox current)))
current custodian-signal undefined bhvr custodian-signal)])
(set-ft-cust-signal! cust custodian-signal)
rtn)))
(fun bhvr)))
(define (propagate b)
(let ([empty-boxes 0]
[dependents (signal-dependents b)]
[depth (signal-depth b)])
(for-each
(lambda (wb)
(match (weak-box-value wb)
[(and dep (? signal?) (= signal-stale? #f))
(set-signal-stale?! dep #t)
; If I'm crossing a "back" edge (one potentially causing a cycle),
; then I send a message. Otherwise, I add to the internal
; priority queue.
(if (< depth (signal-depth dep))
(iq-enqueue dep)
(! man dep))]
[_
(set! empty-boxes (add1 empty-boxes))]))
dependents)
(when (> empty-boxes 9)
(set-signal-dependents!
b
(filter weak-box-value dependents)))))
(define (update0 b)
(match b
[(and (? signal?)
(= signal-value value)
(= signal-thunk thunk)
(= signal-custodians custs))
(set-signal-stale?! b #f)
(let ([new-value (parameterize ([current-custs custs])
(thunk))])
(if (or (signal:unchanged? b) (not (eq? value new-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))))]
[_ (void)]))
(define (update1 b a)
(match b
[(and (? signal?)
(= signal-value value)
(= signal-thunk thunk))
(set-signal-stale?! b #f)
(let ([new-value (thunk a)])
(when (not (equal? value new-value))
(set-signal-value! b new-value)
(propagate b)))]
[_ (void)]))
(define (signal-count)
(! man `(stat ,(self)))
(receive [n n]))
;;;;;;;;;;;;;
;; Manager ;;
;;;;;;;;;;;;;
;; the manager of all signals and event streams
(define man
(spawn/name
'frtime-heart
(let* ([named-providers (make-hash-table)]
[cur-beh #f]
[signal-cache (make-hash-table 'weak)]
[notifications empty]
;; added for run-thunk/stablized
[thunks-to-run empty]
[do-and-queue (lambda (pid thnk)
(with-handlers
([exn:fail? (lambda (exn)
(set! notifications
(cons (list pid 'exn exn)
notifications)))])
(set! notifications
(cons (list* pid 'vals (call-with-values thnk list))
notifications))))])
(let outer ()
(with-handlers ([exn:fail?
(lambda (exn)
(when (and cur-beh
#;(not (undefined? (signal-value cur-beh))))
#(when (empty? (continuation-mark-set->list
(exn-continuation-marks exn) 'frtime))
(set! exn (make-exn:fail (exn-message exn)
(signal-continuation-marks
cur-beh))))
;(raise exn)
(iq-enqueue (list exceptions (list exn cur-beh)))
(when (behavior? cur-beh)
(undef cur-beh)
#;(kill-signal cur-beh)))
(outer))])
(let inner ()
;; process external messages until there is an internal update
;; or an expired alarm
(let loop ()
(receive [after (cond
[(not (iq-empty?)) 0]
[(not (alarms-empty?)) (- (alarms-peak-ms)
(current-milliseconds))]
[else #f])
(void)]
[(? signal? b)
(iq-enqueue b)
(loop)]
[($ external-event recip-val-pairs)
(for-each iq-enqueue recip-val-pairs)
(loop)]
[($ alarm ms beh)
(schedule-alarm ms beh)
(loop)]
[('run-thunk rtn-pid thunk)
(begin
(do-and-queue rtn-pid thunk)
; (with-handlers
; ([exn:fail? (lambda (exn)
; (set! notifications
; (cons (list rtn-pid 'exn exn)
; notifications)))])
; (set! notifications (cons (list rtn-pid 'val (thunk))
; notifications)))
(loop))]
;; !Experimental!
;; queues thunks to be evaluated after this round of computation,
;; but before the next round
[('run-thunk/stabilized rtn-pid thunk)
(begin
(set! thunks-to-run (cons (list rtn-pid thunk) thunks-to-run))
(loop))]
[('stat rtn-pid)
(let ([x 0])
(hash-table-for-each signal-cache (lambda (k v)
(if k (set! x (add1 x)))))
(! rtn-pid x))]
[('bind sym evt)
(let ([forwarder+listeners (cons #f empty)])
(set-car! forwarder+listeners
(event-forwarder sym evt forwarder+listeners))
(hash-table-put! named-providers sym forwarder+listeners))
(loop)]
[('remote-reg tid sym)
(let ([f+l (hash-table-get named-providers sym)])
(when (not (member tid (rest f+l)))
(set-rest! f+l (cons tid (rest f+l)))))
(loop)]
[('remote-evt sym val)
(iq-enqueue
(list (hash-table-get named-dependents sym (lambda () dummy)) val))
(loop)]
[msg
(fprintf (current-error-port)
"frtime engine: msg not understood: ~a~n"
msg)
(loop)]))
;; enqueue expired timers for execution
(let loop ()
(unless (or (alarms-empty?)
(< (current-milliseconds)
(alarms-peak-ms)))
(let ([beh (alarms-dequeue-beh)])
(when (and beh (not (signal-stale? beh)))
(set-signal-stale?! beh #t)
(iq-enqueue beh)))
(loop)))
;; process internal updates
(let loop ()
(unless (iq-empty?)
(match (iq-dequeue)
[(b val)
(set! cur-beh b)
(update1 b val)
(set! cur-beh #f)]
[b
(set! cur-beh b)
(update0 b)
(hash-table-get signal-cache b (lambda () (hash-table-put! signal-cache b #t)))
(set! cur-beh #f)])
(loop)))
;; do the run-thunk/stabalized; use existing notification mechanism
(for-each (lambda (pair)
(do-and-queue (first pair) (second pair)))
thunks-to-run)
(for-each (lambda (lst)
(! (first lst) (rest lst)))
notifications)
(set! notifications empty)
(set! thunks-to-run empty)
(inner)))))))
(define exceptions
(event-receiver))
(define dummy (proc->signal void))
(provide (all-defined)))

97
collects/frtime/frp-snip.ss Normal file
View File

@ -0,0 +1,97 @@
(module frp-snip mzscheme
(require (lib "class.ss")
(lib "string.ss")
(lib "list.ss")
;; FRP requires
(lib "frp-core.ss" "frtime")
(all-except (lib "lang-ext.ss" "frtime") undefined?)
; (rename (lib "frp-core.ss" "frtime") behavior? behavior?)
; (rename (lib "lang-ext.ss" "frtime") event? event?)
; (rename (lib "frp-core.ss" "frtime") signal? signal?)
;
; (rename (lib "frp-core.ss" "frtime") econs? econs?)
; (rename (lib "frp-core.ss" "frtime") efirst efirst)
;
; (rename (lib "frp-core.ss" "frtime") value-now value-now)
; (rename (lib "frp-core.ss" "frtime") signal-value signal-value)
; (rename (lib "lang-ext.ss" "frtime") undefined undefined)
; (rename (lib "lang-ext.ss" "frtime") undefined? frp:undefined?)
;
; (rename (lib "frp-core.ss" "frtime") proc->signal proc->signal)
;; MrEd require
(all-except (lib "mred.ss" "mred") send-event))
(define drs-eventspace #f)
(define (set-eventspace evspc)
(set! drs-eventspace evspc))
(define value-snip-copy%
(class string-snip%
(init-field current parent)
(inherit get-admin)
(define/public (set-current c)
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(lambda ()
(set! current c)
(let ([admin (get-admin)])
(when admin
(send admin needs-update this 0 0 2000 100)))))))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(send current draw dc x y left top right bottom dx dy draw-caret))
(super-instantiate (" "))))
(define (make-snip bhvr)
(make-object string-snip%
(let ([tmp (cond
[(behavior? bhvr) (value-now bhvr)]
[(event? bhvr) (signal-value bhvr)]
[else bhvr])])
(cond
[(econs? tmp) (format "#<event (last: ~a)>" (efirst tmp))]
[(undefined? tmp) "<undefined>"]
[else (expr->string tmp)]))))
(define value-snip%
(class string-snip%
(init-field bhvr)
(field [copies empty]
[loc-bhvr (proc->signal (lambda () (update)) bhvr)]
[current (make-snip bhvr)])
(define/override (copy)
(let ([ret (make-object value-snip-copy% current this)])
(set! copies (cons ret copies))
ret))
(define/public (update)
(set! current (make-snip bhvr))
(for-each (lambda (copy) (send copy set-current current)) copies))
(super-instantiate (" "))))
(define (render beh as-snip?)
(cond
[as-snip? (watch beh)]
[(undefined? (value-now beh)) "<undefined>"]
[(behavior? beh) (format "#<behavior (~a)>" (value-now beh))]
[(event? beh) (format "#<event (last: ~a)>" (efirst (signal-value beh)))]
[else beh]))
(define (watch beh)
(cond
[(undefined? beh)
(begin
;(printf "~a was regarded as undefined~n" beh)
(make-object string-snip% "<undefined>")
)
]
[(signal? beh) (make-object value-snip% beh)]
[else beh]))
(provide (all-defined))
)

995
collects/frtime/frp.ss
View File

File diff suppressed because it is too large Load Diff

4
collects/frtime/frtime-tool.ss
View File

@ -26,8 +26,8 @@
"FrTime without libraries")
(define/public (get-language-url) #f)
(define/public (get-reader)
(lambda (name port offsets)
(let ([v (read-syntax name port offsets)])
(lambda (name port)
(let ([v (read-syntax name port)])
(if (eof-object? v)
v
(namespace-syntax-introduce v)))))

417
collects/frtime/frtime.ss
View File

@ -1,410 +1,11 @@
(module frtime (lib "frp.ss" "frtime")
(require (all-except mzscheme
module
#%app
#%top
#%datum
#%plain-module-begin
#%module-begin
if
require
provide
letrec
match
cons car cdr pair? null? null
caar cdar cadr cddr caddr cdddr cadddr cddddr
;undefined?
and
or
cond when unless
map ormap andmap assoc member)
(rename mzscheme mz:cons cons)
;(rename mzscheme mz:and and)
;(rename mzscheme mz:or or)
;(lib "list.ss")
(lib "contract.ss")
(only "erl.ss" tid?))
(module frtime (lib "mzscheme-utils.ss" "frtime")
(require (lib "lang-ext.ss" "frtime"))
(require (lib "frp-snip.ss" "frtime"))
(require (lib "ft-qq.ss" "frtime"))
(define-syntax cond
(syntax-rules (else =>)
[(_ [else result1 result2 ...])
(begin result1 result2 ...)]
[(_ [test => result])
(let ([temp test])
(if temp (result temp)))]
[(_ [test => result] clause1 clause2 ...)
(let ([temp test])
(if temp
(result temp)
(cond clause1 clause2 ...)
(cond clause1 clause2 ...)))]
[(_ [test]) test]
[(_ [test] clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(cond clause1 clause2 ...)
(cond clause1 clause2 ...)))]
[(_ [test result1 result2 ...])
(if test (begin result1 result2 ...))]
[(_ [test result1 result2 ...]
clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(cond clause1 clause2 ...)
(cond clause1 clause2 ...))]))
;(provide-for-syntax (rename (lib "mzscheme-utils.ss" "frtime") syntax->list syntax->list))
(define-syntax and
(syntax-rules ()
[(_) #t]
[(_ exp) exp]
[(_ exp exps ...) (if exp
(and exps ...)
#f)]))
(define-syntax or
(syntax-rules ()
[(_) #f]
[(_ exp) exp]
[(_ exp exps ...) (let ([v exp])
(if v
v
(or exps ...)
(or-undef exps ...)))]))
(define-syntax or-undef
(syntax-rules ()
[(_) undefined]
[(_ exp) (let ([v exp]) (if v v undefined))]
[(_ exp exps ...) (let ([v exp])
(if v
v
(or-undef exps ...)
(or-undef exps ...)))]))
(define-syntax when
(syntax-rules ()
[(_ test body ...) (if test (begin body ...))]))
(define-syntax unless
(syntax-rules ()
[(_ test body ...) (if (not test) (begin body ...))]))
(define (ormap proc lst)
(and (pair? lst)
(or (proc (car lst)) (ormap proc (cdr lst)))))
(define (andmap proc lst)
(or (null? lst)
(and (proc (car lst)) (andmap proc (cdr lst)))))
(define (caar v)
(car (car v)))
(define (cdar v)
(cdr (car v)))
(define (cadr v)
(car (cdr v)))
(define (cddr v)
(cdr (cdr v)))
(define (caddr v)
(car (cddr v)))
(define (cdddr v)
(cdr (cddr v)))
(define (cadddr v)
(car (cdddr v)))
(define (cddddr v)
(cdr (cdddr v)))
; (define list
; (case-lambda
; [() null]
; [(a . d) (cons a (apply list d))]))
(define-syntax frtime:case
(syntax-rules ()
[(_ exp clause ...)
(let ([v exp])
(vcase v clause ...))]))
(define-syntax vcase
(syntax-rules (else)
[(_ v [else exp ...])
(begin exp ...)]
[(_ v [dl exp ...])
(if (lift #t memv v (quote dl))
(begin exp ...))]
[(_ v [dl exp ...] clause ...)
(if (lift #t memv v (quote dl))
(begin exp ...)
(vcase v clause ...))]))
(define map
(case-lambda
[(f l) (if (pair? l)
(cons (f (car l)) (map f (cdr l)))
null)]
[(f l1 l2) (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))
(cons (lift #f apply f (car l) (map car ls)) (lift #f apply map f (cdr l) (map cdr ls)))
null)]))
; TO DO: assoc member [vectors] structs
; first cut: could be made more efficient by creating
; a dedicated signal to update each element of the vector
(define (frtime:vector2 . args)
(if (ormap behavior? args)
(let* ([n (length args)]
[v1 (make-vector n)]
[v2 (make-vector n)])
(apply
proc->signal
(lambda ()
(let ([tmp v2])
(set! v2 v1)
(set! v1 tmp))
(let loop ([i 0] [args args])
(when (< i n)
(vector-set! v1 i (value-now (car args)))
(loop (add1 i) (cdr args))))
v1)
args))
(apply vector args)))
(define (frtime:vector . args)
(if (ormap behavior? args)
(let* ([n (length args)]
[vec (make-vector n)]
[arg-behs
; initialize the vector
(let loop ([i 0] [args args] [ret null])
(if (< i n)
(loop (add1 i)
(cdr args)
(mz:cons
(let ([arg (car args)])
(proc->signal
(lambda ()
(let ([v (value-now arg)])
(vector-set! vec i v)
v))
arg))
ret))
ret))])
(apply proc->signal (lambda () arg-behs vec) arg-behs))
(apply vector args)))
(define ((behaviorof pred) x)
(let ([v (value-now x)])
(or (undefined? v)
(pred v))))
(define (lift-strict . args)
(apply lift #t args))
;; Imported from mzscheme:
(provide (lifted + - * / = eq? equal? eqv? < > <= >= list? add1 cos sin tan symbol->string symbol?
number->string exp expt even? odd? list-ref string-append eval
sub1 sqrt not number? string? zero? min max modulo
string->number void? rational? char? char-upcase char-ci>=? char-ci<=?
string>=? char-upper-case? char-alphabetic?
string<? string-ci=? string-locale-ci>?
string-locale-ci<? string-locale-ci=? atan asin acos exact? magnitude imag-part
real-part numerator abs log lcm gcd arithmetic-shift integer-sqrt make-rectangular
complex? char>? char<? char=?
char-numeric? date-time-zone-offset list->string substring string->list
string-ci<? string-ci>=? string<=? string-ci<=? string>? string-locale<? string=?
string-length string-ref
floor angle round
ceiling real? date-hour vector-ref procedure? procedure-arity
rationalize date-year-day date-week-day date? date-dst? date-year date-month date-day
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 append length seconds->date
expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
exn:fail?
)
(rename frtime:case case)
(rename frtime:vector vector)
(rename frtime:vector2 vector2)
(rename eq? mzscheme:eq?)
make-exn:fail
make-namespace namespace? namespace-symbol->identifier namespace-variable-value
namespace-set-variable-value! namespace-undefine-variable! namespace-mapped-symbols
parameterize current-seconds current-milliseconds current-inexact-milliseconds
call-with-values make-parameter
null gensym collect-garbage
error define-struct set! printf fprintf current-error-port for-each void
procedure-arity-includes? raise-type-error raise thread
current-continuation-marks
raise-mismatch-error require-for-syntax define-syntax syntax-rules syntax-case
set-eventspace
install-errortrace-key
(lifted:nonstrict apply format list list*)
general-event-processor
lambda
case-lambda
define-values
define
let
let-values
let*
let*-values
begin
begin0
quote
quasiquote
unquote
values
syntax
let/ec
with-handlers
delay
force
random
sleep
)
;; Defined in frp.ss:
(provide module
#%app
#%top
#%datum
#%plain-module-begin
#%module-begin
render
require
provide
letrec
undefined
undefined?
if
lift
match
time-b
seconds
milliseconds
exceptions
cons
pair?
null?
car
cdr
signal-value
signal?
behavior?
event?
event-receiver?
frtime-version
raise-exceptions
synchronize
frp:send
snapshot
snapshot-all
snapshot/sync
snapshot/apply
)
; (define (behavior? v) (not (event? v)))
;; Defined in this module:
(provide when unless behaviorof -=> nothing nothing?
cond and or andmap ormap map lift-strict never-e
caar cadr cdar cddr caddr cdddr cadddr cddddr
magic value-nowable?)
; returns true on values that can be passed to value-now
; (e.g. behaviors or constants)
; note difference from behavior?, which returns true only
; on values that may actually change and should be monitored
; for change
(define (value-nowable? v)
#t)
;(not (and (signal? v) (event-cons? (signal-value v)))))
(provide/contract
[proc->signal (((-> any/c))
any/c
. ->* . (signal?))]
[value-now (value-nowable? . -> . any)]
[until (value-nowable? value-nowable? . -> . behavior?)]
[switch ((event?) (value-nowable?) . opt-> . signal?)]
[merge-e (() (listof event?) . ->* . (event?))]
[once-e (event? . -> . event?)]
[changes (value-nowable? . -> . event?)]
[event-receiver (-> event?)]
[when-e (value-nowable? . -> . event?)]
[while-e (value-nowable? value-nowable? . -> . event?)]
[==> (event? (any/c . -> . any) . -> . event?)]
[=#> (event? (any/c . -> . any) . -> . event?)]
[=#=> (event? (any/c . -> . (union any/c nothing?)) . -> . event?)]
[map-e ((any/c . -> . any) event? . -> . event?)]
[filter-e ((any/c . -> . any) event? . -> . event?)]
[filter-map-e ((any/c . -> . (union any/c nothing?)) event? . -> . event?)]
[collect-e (event? any/c (any/c any/c . -> . any) . -> . event?)]
[collect-b (event? any/c (any/c any/c . -> . any) . -> . behavior?)]
[accum-e (event? any/c . -> . event?)]
[accum-b (event? any/c . -> . behavior?)]
[send-event (event-receiver? any/c . -> . void?)]
[send-synchronous-event (event-receiver? any/c . -> . void?)]
[send-synchronous-events (list? . -> . void?)]
[hold ((event?) (value-nowable?) . opt-> . behavior?)]
[new-cell (() (any/c) . opt-> . (union behavior? event?))]
[set-cell! ((union behavior? event?) any/c . -> . void?)]
[snapshot-e ((event?) any/c . ->* . (event?))]
[snapshot-map-e ((procedure? event?)
any/c ;; the behaviors
. ->* .
(event?))]
[derivative (value-nowable? . -> . behavior?)]
[integral ((value-nowable?) (value-nowable?) . opt-> . behavior?)]
[delay-by (value-nowable? value-nowable? . -> . signal?)]
[inf-delay (value-nowable? . -> . behavior?)]
[bind (symbol? event? . -> . event?)]
[remote-reg (tid? symbol? . -> . event?)]
))
(provide (all-from (lib "mzscheme-utils.ss" "frtime"))
(all-from (lib "lang-ext.ss" "frtime"))
(all-from (lib "frp-snip.ss" "frtime"))
(all-from (lib "ft-qq.ss" "frtime"))))

178
collects/frtime/ft-qq.ss Normal file
View File

@ -0,0 +1,178 @@
(module ft-qq (lib "mzscheme-core.ss" "frtime") ;(lib "frp.ss" "frtime")
(require (as-is:unchecked mzscheme define-values define-syntaxes require-for-syntax
raise-type-error quote unquote unquote-splicing))
;(require-for-syntax (lib "frp.ss" "frtime"))
(require-for-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)))

7
collects/frtime/graphics-posn-less-unit.ss
View File

@ -11,9 +11,10 @@
(lib "class100.ss")
(lib "etc.ss")
"erl.ss"
(only "frp.ss" event-receiver)
(rename "frp.ss" frp-man man)
(only "frp.ss" send-event)
;(rename "frp-core.ss" event-receiver event-receiver)
;(rename "frp-core.ss" frp-man man)
;(rename "frp-core.ss" send-event send-event)
(lib "frp-core.ss" "frtime")
"graphics-sig.ss")
(provide graphics-posn-less@)

1
collects/frtime/gui.ss
View File

@ -3,6 +3,7 @@
(all-except (lib "etc.ss") rec)
(lib "list.ss")
(lib "class.ss")
(rename (lib "frp-core.ss" "frtime") proc->signal proc->signal)
(all-except (lib "mred.ss" "mred") send-event))
(define reactive-control<%>

741
collects/frtime/lang-ext.ss Normal file
View File

@ -0,0 +1,741 @@
(module lang-ext mzscheme
(require (lib "frp-core.ss" "frtime")
(lib "etc.ss")
(lib "list.ss"))
(require-for-syntax (lib "list.ss"))
(define nothing (void));(string->uninterned-symbol "nothing"))
(define (nothing? v) (eq? v nothing))
; new-cell : behavior[a] -> behavior[a] (cell)
(define new-cell
(opt-lambda ([init undefined])
(switch (event-receiver) init)))
(define (b1 . until . b2)
(proc->signal
(lambda () (if (undefined? (value-now b2))
(value-now b1)
(value-now b2)))
; deps
b1 b2))
(define-syntax (event-loop-help stx)
(syntax-case stx ()
[(_ ([name expr] ...)
[e => body] ...)
(with-syntax ([args #'(name ...)])
#'(accum-e
(merge-e
(e . ==> . (lambda (v)
(lambda (state)
(apply
(lambda args (body v))
state)))) ...)
(list expr ...)))]))
(define-syntax (event-loop stx)
(define (add-arrow clause)
(syntax-case clause (=>)
[(e => body) #'(e => body)]
[(e body) #'(e => (lambda (_) body))]))
(syntax-case stx ()
[(_ ([name expr] ...)
clause ...)
(with-syntax ([(new-clause ...)
(map add-arrow (syntax->list #'(clause ...)))])
#'(event-loop-help
([name expr] ...)
new-clause ...)
)]))
(define undefined?/lifted (lambda (arg) (lift false undefined? arg)))
(define (event? v)
(and (signal? v)
(if (undefined? (signal-value v))
undefined
(event-cons? (signal-value v)))))
(define-syntax (event-producer stx)
(syntax-case stx ()
[(src-event-producer expr dep ...)
(with-syntax ([emit (datum->syntax-object (syntax src-event-producer) 'emit)]
[the-args (datum->syntax-object
(syntax src-event-producer) 'the-args)])
(syntax (let* ([out (econs undefined undefined)]
[emit (lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out)))])
(proc->signal (lambda the-args expr out) dep ...))))]))
; switch : event[behavior] behavior -> behavior
(define switch
(opt-lambda (e [init undefined])
(let* ([init (box init)]
[e-b (hold e (unbox init))])
(rec ret
(proc->signal:switching
(case-lambda
[()
(when (not (eq? (unbox init) (signal-value e-b)))
(unregister ret (unbox init))
(set-box! init (value-now/no-copy e-b))
(register ret (unbox init))
(set-signal-producers! ret (list e-b (unbox init)))
(set-signal-depth! ret (max (signal-depth ret)
(add1 (safe-signal-depth (unbox init)))))
(iq-resort))
(value-now/no-copy (unbox init))]
[(msg) e])
init
e-b
e-b (unbox init))))))
; event ... -> event
(define (merge-e . args)
(apply event-processor
(lambda (emit)
(lambda (the-event)
(emit the-event)))
args))
(define (once-e e)
(let ([b #t])
(rec ret (event-processor
(lambda (emit)
(lambda (the-event)
(when b
(set! b false)
(unregister ret e)
(emit the-event))))
e))))
; behavior[a] -> event[a]
(define (changes b)
(event-producer2
(lambda (emit)
(lambda the-args
(emit (value-now b))))
b))
; when-e : behavior[bool] -> event
(define (when-e b)
(let* ([last (value-now b)])
(event-producer2
(lambda (emit)
(lambda the-args
(let ([current (value-now b)])
(when (and (not last) current)
(emit current))
(set! last current))))
b)))
; while-e : behavior[bool] behavior[number] -> event
(define (while-e b interval)
(rec ret (event-producer2
(lambda (emit)
(lambda the-args
(cond
[(value-now b) =>
(lambda (v)
(emit v)
(schedule-alarm (+ (value-now interval) (current-milliseconds)) ret))])))
b)))
; ==> : event[a] (a -> b) -> event[b]
(define (e . ==> . f)
(event-processor
(lambda (emit)
(lambda (the-event)
(emit ((value-now f) the-event))))
e))
#|
(define (e . =>! . f)
(event-processor
((value-now f) the-event)
(list e)))
|#
; -=> : event[a] b -> event[b]
(define-syntax -=>
(syntax-rules ()
[(_ e k-e) (==> e (lambda (_) k-e))]))
; =#> : event[a] (a -> bool) -> event[a]
(define (e . =#> . p)
(event-processor
(lambda (emit)
(lambda (the-event)
(when (value-now (p the-event))
(emit the-event))))
e))
; =#=> : event[a] (a -> b U nothing) -> event[b]
(define (e . =#=> . f)
(event-processor
(lambda (emit)
(lambda (the-event)
(let ([x (f the-event)])
(unless (or (nothing? x) (undefined? x))
(emit x)))))
e))
(define (map-e f e)
(==> e f))
(define (filter-e p e)
(=#> e p))
(define (filter-map-e f e)
(=#=> e f))
; event[a] b (a b -> b) -> event[b]
(define (collect-e e init trans)
(event-processor
(lambda (emit)
(lambda (the-event)
(let ([ret (trans the-event init)])
(set! init ret)
(emit ret))))
e))
; event[(a -> a)] a -> event[a]
(define (accum-e e init)
(event-processor
(lambda (emit)
(lambda (the-event)
(let ([ret (the-event init)])
(set! init ret)
(emit ret))))
e))
; event[a] b (a b -> b) -> behavior[b]
(define (collect-b ev init trans)
(hold (collect-e ev init trans) init))
; event[(a -> a)] a -> behavior[a]
(define (accum-b ev init)
(hold (accum-e ev init) init))
; hold : a event[a] -> behavior[a]
(define hold
(opt-lambda (e [init undefined])
(let ([val init])
(let* ([updator (event-processor
(lambda (emit)
(lambda (the-event)
(set! val the-event)
(emit the-event)))
e)]
[rtn (proc->signal (lambda () updator val) updator)])
rtn))))
(define-syntax snapshot/sync
(syntax-rules ()
[(_ (id ...) expr ...)
(let-values ([(id ...) (sync/read id ...)])
expr ...)]))
(define-syntax snapshot
(syntax-rules ()
[(_ (id ...) expr ...)
(let ([id (value-now id)] ...)
expr ...)]))
(define-syntax snapshot-all
(syntax-rules ()
[(_ expr ...)
(parameterize ([snap? #t])
expr ...)]))
(define (snapshot-e e . bs)
(event-processor
(lambda (emit)
(lambda (the-event)
(emit (cons the-event (map value-now bs)))))
e))
(define (snapshot/apply fn . args)
(apply fn (map value-now args)))
;; Deprecated
(define-syntax frp:send
(syntax-rules ()
[(_ obj meth arg ...)
(if (snap?)
(send obj meth (value-now arg) ...)
(send obj meth arg ...))]))
;; Depricated
(define (magic dtime thunk)
(let* ([last-time (current-milliseconds)]
[ret (let ([myself #f])
(event-producer
(let ([now (current-milliseconds)])
(snapshot (dtime)
(when (cons? the-args)
(set! myself (first the-args)))
(when (and dtime (>= now (+ last-time dtime)))
(emit (thunk))
(set! last-time now))
(when dtime
(schedule-alarm (+ last-time dtime) myself))))
dtime))])
(send-event ret ret)
ret))
;; Depricated
(define (make-time-b ms)
(let ([ret (proc->signal void)])
(set-signal-thunk! ret
(lambda ()
(let ([t (current-milliseconds)])
(schedule-alarm (+ ms t) ret)
t)))
(set-signal-value! ret ((signal-thunk ret)))
ret))
(define milliseconds (make-time-b 20))
(define time-b milliseconds)
(define seconds
(let ([ret (proc->signal void)])
(set-signal-thunk! ret
(lambda ()
(let ([s (current-seconds)]
[t (current-milliseconds)])
(schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret)
s)))
(set-signal-value! ret ((signal-thunk ret)))
ret))
; general efficiency fix for delay
; signal[a] signal[num] -> signal[a]
(define (delay-by beh ms-b)
(letrec ([last (cons (cons (if (zero? (value-now ms-b))
(value-now/no-copy beh)
undefined)
(current-milliseconds))
empty)]
[head last]
[producer (proc->signal
(lambda ()
(let* ([now (current-milliseconds)]
[ms (value-now ms-b)])
(let loop ()
(if (or (empty? (rest head))
(< now (+ ms (cdadr head))))
(caar head)
(begin
consumer ;; just to prevent GC
(set! head (rest head))
(loop)))))))]
[consumer (proc->signal
(lambda ()
(let* ([now (current-milliseconds)]
[new (value-now beh)]
[ms (value-now ms-b)])
(when (not (equal? new (caar last)))
(set-rest! last (cons (cons new now)
empty))
(set! last (rest last))
(schedule-alarm (+ now ms) producer))))
beh ms-b)])
producer))
(define (inf-delay beh)
(delay-by beh 0))
; fix to take arbitrary monotonically increasing number
; (instead of milliseconds)
; integral : signal[num] signal[num] -> signal[num]
(define integral
(opt-lambda (b [ms-b 20])
(letrec ([accum 0]
[last-time (current-milliseconds)]
[last-val (value-now b)]
[last-alarm 0]
[producer (proc->signal (lambda ()
consumer ;; just to prevent GC
accum))]
[consumer (proc->signal void b ms-b)])
(set-signal-thunk!
consumer
(lambda ()
(let ([now (current-milliseconds)])
(if (> now (+ last-time 20))
(begin
(when (not (number? last-val))
(set! last-val 0))
(set! accum (+ accum
(* last-val
(- now last-time))))
(set! last-time now)
(set! last-val (value-now b))
(when (value-now ms-b)
(schedule-alarm (+ last-time (value-now ms-b))
consumer)))
(when (or (>= now last-alarm)
(and (< now 0)
(>= last-alarm 0)))
(set! last-alarm (+ now 20))
(schedule-alarm last-alarm consumer)))
(schedule-alarm now producer))))
((signal-thunk consumer))
producer)))
; fix for accuracy
; derivative : signal[num] -> signal[num]
(define (derivative b)
(let* ([last-value (value-now b)]
[last-time (current-milliseconds)]
[thunk (lambda ()
(let* ([new-value (value-now b)]
[new-time (current-milliseconds)]
[result (if (or (= new-value last-value)
(= new-time last-time)
(> new-time
(+ 500 last-time))
(not (number? last-value))
(not (number? new-value)))
0
(/ (- new-value last-value)
(- new-time last-time)))])
(set! last-value new-value)
(set! last-time new-time)
result))])
(proc->signal thunk b)))
(define create-strict-thunk
(case-lambda
[(fn) fn]
[(fn arg1) (lambda ()
(let ([a1 (value-now/no-copy arg1)])
(if (undefined? a1)
undefined
(fn a1))))]
[(fn arg1 arg2) (lambda ()
(let ([a1 (value-now/no-copy arg1)]
[a2 (value-now/no-copy arg2)])
(if (or (undefined? a1)
(undefined? a2))
undefined
(fn a1 a2))))]
[(fn arg1 arg2 arg3) (lambda ()
(let ([a1 (value-now/no-copy arg1)]
[a2 (value-now/no-copy arg2)]
[a3 (value-now/no-copy arg3)])
(if (or (undefined? a1)
(undefined? a2)
(undefined? a3))
undefined
(fn a1 a2 a3))))]
[(fn . args) (lambda ()
(let ([as (map value-now/no-copy args)])
(if (ormap undefined? as)
undefined
(apply fn as))))]))
(define create-thunk
(case-lambda
[(fn) fn]
[(fn arg1) (lambda () (fn (value-now/no-copy arg1)))]
[(fn arg1 arg2) (lambda () (fn (value-now/no-copy arg1) (value-now/no-copy arg2)))]
[(fn arg1 arg2 arg3) (lambda () (fn (value-now/no-copy arg1)
(value-now/no-copy arg2)
(value-now/no-copy arg3)))]
[(fn . args) (lambda () (apply fn (map value-now/no-copy args)))]))
(define (lift strict? fn . args)
(if (snap?) ;; maybe fix later to handle undefined-strictness
(apply fn (map value-now/no-copy args))
(with-continuation-mark
'frtime 'lift-active
(if (ormap behavior? args)
(begin
(when (ormap signal:compound? args)
(printf "attempting to lift ~a over a signal:compound in ~a!~n" fn (map value-now args)))
(apply
proc->signal
(apply (if strict? create-strict-thunk create-thunk) fn args)
args))
(if (and strict? (ormap undefined? args))
undefined
(apply fn args))))))
(define (lift-strict . args)
(apply lift #t args))
(define (general-event-processor proc . args)
; proc : (lambda (emit suspend first-evt) ...)
(let* ([out (econs undefined undefined)]
[esc #f]
[emit (lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val)]
[streams (map signal-value args)])
(letrec ([suspend (lambda ()
(call/cc
(lambda (k)
(set! proc-k k)
(esc (void)))))]
[proc-k (lambda (evt) (proc emit suspend evt) (set! proc-k #f))])
(let ([thunk (lambda ()
(when (ormap undefined? streams)
;(fprintf (current-error-port) "had an undefined stream~n")
(set! streams (fix-streams streams args)))
(let loop ()
(extract (lambda (the-event)
(when proc-k
(call/cc
(lambda (k)
(set! esc k)
(proc-k the-event)))) (loop))
streams))
(set! streams (map signal-value args))
out)])
(apply proc->signal thunk args)))))
(define (event-processor proc . args)
(let* ([out (econs undefined undefined)]
[proc/emit (proc
(lambda (val)
(set-erest! out (econs val undefined))
(set! out (erest out))
val))]
[streams (map signal-value args)]
[thunk (lambda ()
(when (ormap undefined? streams)
;(fprintf (current-error-port) "had an undefined stream~n")
(set! streams (fix-streams streams args)))
(let loop ()
(extract (lambda (the-event) (proc/emit the-event) (loop))
streams))
(set! streams (map signal-value args))
out)])
(apply proc->signal thunk args)))
;;;;;;;;;;;;;;;;;;;;;;
;; Command Lambda
(define-syntax mk-command-lambda
(syntax-rules ()
[(_ (free ...) forms body ...)
(if (ormap behavior? (list free ...))
(procs->signal:compound
(lambda x (lambda forms
(snapshot (free ...) body ...)))
(lambda (a b) void)
free ...)
(lambda forms body ...))]))
(define-syntax (command-lambda stx)
(define (arglist-bindings arglist-stx)
(syntax-case arglist-stx ()
[var
(identifier? arglist-stx)
(list arglist-stx)]
[(var ...)
(syntax->list arglist-stx)]
[(var . others)
(cons #'var (arglist-bindings #'others))]))
(define (make-snapshot-unbound insp unbound-ids)
(lambda (expr bound-ids)
(let snapshot-unbound ([expr expr] [bound-ids bound-ids])
(syntax-recertify
(syntax-case expr (#%datum
quote
#%top
let-values
letrec-values
lambda)
[x (identifier? #'x) (if (or
(syntax-property #'x 'protected)
(ormap (lambda (id)
(bound-identifier=? id #'x)) bound-ids))
#'x
(begin
(hash-table-put! unbound-ids #'x #t)
#'(#%app value-now x)))]
[(#%datum . val) expr]
[(quote . _) expr]
[(#%top . var) (begin
(hash-table-put! unbound-ids #'var #t)
#`(#%app value-now #,expr))] ; FIX
[(letrec-values (((variable ...) in-e) ...) body-e ...)
(let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)])
(with-syntax ([(new-in-e ...) (map (lambda (exp)
(snapshot-unbound exp new-bound-ids))
(syntax->list #'(in-e ...)))]
[(new-body-e ...) (map (lambda (exp)
(snapshot-unbound exp new-bound-ids))
(syntax->list #'(body-e ...)))])
#'(letrec-values (((variable ...) new-in-e) ...) new-body-e ...)))]
[(let-values (((variable ...) in-e) ...) body-e ...)
(let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)])
(with-syntax ([(new-in-e ...) (map (lambda (exp)
(snapshot-unbound exp bound-ids))
(syntax->list #'(in-e ...)))]
[(new-body-e ...) (map (lambda (exp)
(snapshot-unbound exp new-bound-ids))
(syntax->list #'(body-e ...)))])
#'(let-values (((variable ...) new-in-e) ...) new-body-e ...)))]
[(lambda forms body-e ...)
(let ([new-bound-ids (append (arglist-bindings #'forms) bound-ids)])
(with-syntax ([(new-body-e ...) (map (lambda (exp)
(snapshot-unbound exp new-bound-ids))
(syntax->list #'(body-e ...)))])
#'(lambda forms new-body-e ...)))]
[(tag exp ...)
(with-syntax ([(new-exp ...) (map (lambda (exp)
(snapshot-unbound exp bound-ids))
(syntax->list #'(exp ...)))])
#'(tag new-exp ...))]
[x (begin
(fprintf (current-error-port) "snapshot-unbound: fell through on ~a~n" #'x)
())])
expr insp #f))))
(syntax-case stx ()
[(src-command-lambda (id ...) expr ...)
(let ([c-insp (current-code-inspector)])
(parameterize ([current-code-inspector (make-inspector)])
(syntax-case (local-expand #'(lambda (id ...) expr ...) 'expression ()) (lambda)
[(lambda (id ...) expr ...)
(let ([unbound-ids (make-hash-table)])
(with-syntax ([(new-expr ...) (map (lambda (exp)
((make-snapshot-unbound c-insp unbound-ids)
exp
(syntax->list #'(id ...))))
(syntax->list #'(expr ...)))]
[(free-var ...) (hash-table-map unbound-ids
(lambda (k v) k))])
(begin
;(printf "~a~n" unbound-ids)
#'(if (ormap behavior? (list free-var ...))
(procs->signal:compound (lambda _
(lambda (id ...)
new-expr ...))
(lambda (a b) void)
free-var ...)
(lambda (id ...) expr ...)))))])))]))
(define for-each-e!
(let ([ht (make-hash-table 'weak)])
(opt-lambda (ev proc [ref 'dummy])
(hash-table-put! ht ref (cons (ev . ==> . proc) (hash-table-get ht ref (lambda () empty)))))))
(define raise-exceptions (new-cell #t))
(define exception-raiser
(exceptions . ==> . (lambda (p) (when (value-now raise-exceptions)
(thread
(lambda () (raise (car p))))))))
(provide raise-exceptions
nothing
nothing?
general-event-processor
event-processor
switch
merge-e
once-e
changes
when-e
while-e
==>
-=>
=#>
=#=>
map-e
filter-e
filter-map-e
collect-e
accum-e
collect-b
accum-b
hold
for-each-e!
snapshot/sync
snapshot
snapshot-e
snapshot/apply
magic
milliseconds
seconds
delay-by
inf-delay
integral
derivative
new-cell
lift
lift-strict
event?
command-lambda
mk-command-lambda
until
event-loop
;; from frp-core
event-receiver
send-event
send-synchronous-event
send-synchronous-events
set-cell!
undefined
(rename undefined?/lifted undefined?)
(rename undefined? frp:undefined?)
behavior?
value-now
value-now/no-copy
value-now/sync
frtime-version
signal-count
)
)

13
collects/frtime/list.ss
View File

@ -2,8 +2,8 @@
(require (lifted (lib "list.ss") quicksort mergesort
fifth sixth seventh eighth
last-pair empty? cons?)
(only (lib "list.ss") empty))
last-pair)
(rename (lib "list.ss") empty empty))
(define first car)
(define rest cdr)
@ -11,8 +11,10 @@
(define third caddr)
(define fourth cadddr)
(define empty? null?)
(define remove
(letrec ([rm (case-lambda
(letrec ([rm (case-lambda
[(item list) (rm item list equal?)]
[(item list equal?)
(let loop ([list list])
@ -152,4 +154,7 @@
[(f (first l)) (cons (first l) (filter f (rest l)))]
[else (filter f (rest l))]))
(provide (all-defined) empty))
(define (cons? x) (pair? x))
(provide (all-defined) empty))

413
collects/frtime/mzscheme-core.ss Normal file
View File

@ -0,0 +1,413 @@
(module mzscheme-core mzscheme
;(require (all-except mzscheme provide module if require letrec null?)
;(lib "list.ss"))
(require-for-syntax (lib "struct.ss" "frtime") (lib "list.ss"))
(require (lib "list.ss")
(lib "frp-core.ss" "frtime")
(rename (lib "lang-ext.ss" "frtime") lift lift)
(rename (lib "lang-ext.ss" "frtime") new-cell new-cell))
;;;;;;;;;;;;;;;;;;;;;;;;
;; Fundamental Macros ;;
;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax frp:letrec
(syntax-rules ()
[(_ ([id val] ...) expr ...)
(let ([id (new-cell)] ...)
(let ([tmp val])
(if (signal? tmp)
(set-cell! id tmp)
(set! id tmp)))
...
expr ...)]))
;(define-syntax frp:match
; (syntax-rules ()
; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
(define (->boolean x)
(if x #t #f))
(define-syntax frp:if
(syntax-rules ()
[(_ test-exp then-exp)
(frp:if test-exp then-exp (void))]
[(_ test-exp then-exp else-exp)
(frp:if test-exp then-exp else-exp undefined)]
[(_ 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]
[else else-exp]))
(lift #t ->boolean test-exp))]))
(define (copy-list lst)
(frp:if (null? lst)
()
(frp:cons (frp:car lst) (copy-list (frp:cdr lst)))))
(define-syntax frp:let-values
(syntax-rules ()
[(_ ([vars expr] ...) body0 body1 ...)
(let-values ([vars (split-multiple expr)] ...)
body0 body1 ...)]))
(define-for-syntax (get-rest-arg arglist-stx)
(syntax-case arglist-stx ()
[var
(identifier? arglist-stx)
arglist-stx]
[(var ...)
#f]
[(var . others)
(get-rest-arg #'others)]))
(define-for-syntax (translate-clause stx)
(syntax-case stx ()
[(bindings body0 body1 ...)
(let ([the-rest-arg (get-rest-arg #'bindings)])
(if the-rest-arg
#`(bindings
(let ([#,the-rest-arg (copy-list #,the-rest-arg)])
body0 body1 ...))
#'(bindings body0 body1 ...)))]))
(define-syntax (frp:lambda stx)
(syntax-case stx ()
[(_ bindings body0 body1 ...)
(with-syntax ([new-clause (translate-clause #'(bindings body0 body1 ...))])
#'(lambda . new-clause))]))
(define-syntax (frp:case-lambda stx)
(syntax-case stx ()
[(_ clause ...)
(with-syntax ([(new-clause ...)
(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)))))
|#
;;;;;;;;;;;;;;;;
;; Structures ;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONS
(define (frp: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 (make-accessor acc)
(lambda (v)
(let loop ([v v])
(cond
[(signal:compound? v) (acc (signal:compound-content v))]
[(signal:switching? v) (super-lift
(lambda (_)
(loop (unbox (signal:switching-current v))))
(signal:switching-trigger v))]
[(signal? v) (printf "access to ~a in ~a~n" acc (value-now/no-copy v)) (lift #t acc v)]
[else (acc v)]))))
(define frp:car
(make-accessor car))
(define frp:cdr
(make-accessor cdr))
(define frp:pair? (lambda (arg) (if (signal:compound? arg)
(pair? (signal:compound-content arg))
(lift #t pair? arg))))
(define (frp:null? arg)
(if (signal:compound? arg)
#f
(lift #t null? arg)))
(define frp:empty? frp:null?)
(define frp:append
(case-lambda
[() ()]
[(lst) lst]
[(lst1 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)))]))
(define frp:list
(lambda elts
(frp:if (frp:empty? elts)
'()
(frp:cons (frp:car elts)
(apply frp:list (frp:cdr elts))))))
(define frp:list*
(lambda elts
(frp:if (frp:empty? elts)
'()
(frp:if (frp:empty? (frp:cdr elts))
(frp:car elts)
(frp:cons (frp:car elts)
(apply frp:list* (frp:cdr elts)))))))
(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))
(if (signal? itm)
(frp:if (lift #t cons? itm)
(frp:list? (frp:cdr itm))
(frp:null? itm))
(or (null? itm)
(and (cons? itm) (frp:list? (cdr itm)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
[(signal:compound? v) (vector-ref (signal:compound-content v) i)]
[(signal? v) (lift #t vector-ref v i)]
[else (vector-ref v i)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make-struct-type + define-struct Macros
(define (frp:make-struct-type name-symbol super-struct-type init-field-k auto-field-k . args)
(let-values ([(desc ctor pred acc mut)
(apply make-struct-type name-symbol super-struct-type init-field-k auto-field-k
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)))
(lambda (v) (if (signal:compound? v)
(pred (value-now/no-copy v))
(lift #t pred v)))
acc
mut)))
(define (frp:make-struct-field-accessor acc i sym)
(make-accessor (make-struct-field-accessor acc i sym)))
; FORBIDS MUTATION
(define (frp:make-struct-field-mutator acc i sym)
(lambda (s)
(error "MUTATION NOT ALLOWED IN FrTime STRUCTURES")))
(define-syntax (frp:define-struct stx)
(syntax-case stx ()
[(_ (s t) (field ...) insp)
(let ([field-names (syntax->list #'(field ...))]
[super-for-gen (if (syntax-e #'t)
(string->symbol
(format "struct:~a" (syntax-e #'t)))
#f)]
[super-for-exp (if (syntax-e #'t)
#'t
#t)])
#`(begin
(define-values #,(build-struct-names #'s field-names #f #f stx)
(parameterize ([current-inspector insp])
#,(build-struct-generation #'s field-names #f #f super-for-gen)))
(define-syntax s
#,(build-struct-expand-info #'s field-names #f #f super-for-exp
empty empty))))]
[(_ (s t) (field ...))
#'(frp:define-struct (s t) (field ...) (current-inspector))]
[(_ s (field ...) insp)
#'(frp:define-struct (s #f) (field ...) insp)]
[(_ s (field ...))
#'(frp:define-struct (s #f) (field ...) (current-inspector))]))
;;;;;;;;;;;;;;;;;;;;;;;
;; Provide & Require ;;
;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax (frp:provide stx)
(syntax-case stx ()
[(_ . clauses)
(foldl
(lambda (c prev)
(syntax-case prev ()
[(begin clause ...)
(syntax-case c (lifted lifted:nonstrict)
[(lifted . ids)
(with-syntax ([(fun-name ...) (syntax ids)]
[(tmp-name ...)
(map (lambda (id)
(datum->syntax-object stx (syntax-object->datum id)))
(generate-temporaries (syntax ids)))])
(syntax
(begin
clause ...
(define (tmp-name . args)
(apply lift #t fun-name args))
...
(provide (rename tmp-name fun-name) ...))))]
[(lifted:nonstrict . ids)
(with-syntax ([(fun-name ...) (syntax ids)]
[(tmp-name ...)
(map (lambda (id)
(datum->syntax-object stx (syntax-object->datum id)))
(generate-temporaries (syntax ids)))])
(syntax
(begin
clause ...
(define (tmp-name . args)
(apply lift #f fun-name args))
...
(provide (rename tmp-name fun-name) ...))))]
[provide-spec
(syntax (begin clause ... (provide provide-spec)))])]))
(syntax (begin))
(syntax->list (syntax clauses)))]))
(define-syntax (frp:require stx)
(define (generate-temporaries/loc st ids)
(map (lambda (id)
(datum->syntax-object stx (syntax-object->datum id)))
(generate-temporaries ids)))
(syntax-case stx ()
[(_ . clauses)
(foldl
(lambda (c prev)
(syntax-case prev ()
[(begin clause ...)
(syntax-case c (lifted lifted:nonstrict as-is:unchecked as-is frlibs)
[(lifted:nonstrict module . ids)
(with-syntax ([(fun-name ...) #'ids]
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
#'(begin
clause ...
(require (rename module tmp-name fun-name) ...)
(define (fun-name . args)
(apply lift false tmp-name args))
...))]
[(lifted module . ids)
(with-syntax ([(fun-name ...) (syntax ids)]
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
#'(begin
clause ...
(require (rename module tmp-name fun-name) ...)
(define (fun-name . args)
(apply lift #t tmp-name args))
...))]
[(as-is:unchecked module id ...)
(syntax (begin clause ... (require (rename module id id) ...)))]
[(as-is module . ids)
(with-syntax ([(fun-name ...) (syntax ids)]
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
#'(begin
clause ...
(require (rename module tmp-name fun-name) ...)
(define fun-name (ensure-no-signal-args tmp-name 'fun-name))
...))]
[(frlibs str ...)
#'(begin
clause ...
(require (lib str "frtime") ...))]
[require-spec
#'(begin clause ... (require require-spec))])]))
#'(begin)
(syntax->list #'clauses))]))
(provide module
#%app
#%top
#%datum
#%plain-module-begin
#%module-begin
(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)
(rename frp:cdr cdr)
(rename frp:list list)
(rename frp:list? list?)
(rename frp:list* list*)
(rename frp:null? null?)
(rename frp:pair? pair?)
(rename frp:append append)
(rename frp:vector vector)
(rename frp:vector-ref vector-ref)
(rename frp:make-struct-type make-struct-type)
(rename frp:make-struct-field-accessor make-struct-field-accessor)
(rename frp:make-struct-field-mutator make-struct-field-mutator)
(rename frp:define-struct define-struct)
(rename frp:provide provide)
(rename frp:require require)))

362
collects/frtime/mzscheme-utils.ss Normal file
View File

@ -0,0 +1,362 @@
(module mzscheme-utils (lib "mzscheme-core.ss" "frtime")
(require (all-except mzscheme
module
#%app
#%top
#%datum
#%plain-module-begin
#%module-begin
if
lambda
case-lambda
;apply
reverse
list-ref
require
provide
letrec
match
cons car cdr pair? null?
caar cdar cadr cddr caddr cdddr cadddr cddddr
make-struct-type
make-struct-field-accessor
make-struct-field-mutator
vector
vector-ref
quasiquote
;qq-append
define-struct
list
list*
list?
append
and
or
cond when unless ;case
map ormap andmap assoc member)
(rename mzscheme mzscheme:if if)
(rename (lib "lang-ext.ss" "frtime") lift lift)
(rename (lib "frp-core.ss" "frtime") super-lift super-lift)
(rename (lib "frp-core.ss" "frtime") behavior? behavior?)
(rename (lib "lang-ext.ss" "frtime") undefined undefined)
(rename (lib "lang-ext.ss" "frtime") undefined? undefined?))
(define (list-ref lst idx)
(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 ...])
(begin result1 result2 ...)]
[(_ [test => result])
(let ([temp test])
(if temp (result temp)))]
[(_ [test => result] clause1 clause2 ...)
(let ([temp test])
(if temp
(result temp)
(cond clause1 clause2 ...)
(cond clause1 clause2 ...)))]
[(_ [test]) test]
[(_ [test] clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(cond clause1 clause2 ...)
(cond clause1 clause2 ...)))]
[(_ [test result1 result2 ...])
(if test (begin result1 result2 ...))]
[(_ [test result1 result2 ...]
clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(cond clause1 clause2 ...)
(cond clause1 clause2 ...))]))
(define-syntax and
(syntax-rules ()
[(_) #t]
[(_ exp) exp]
[(_ exp exps ...) (if exp
(and exps ...)
#f)]))
(define-syntax or
(syntax-rules ()
[(_) #f]
[(_ exp) exp]
[(_ exp exps ...) (let ([v exp])
(if v
v
(or exps ...)
(or-undef exps ...)))]))
(define-syntax or-undef
(syntax-rules ()
[(_) undefined]
[(_ exp) (let ([v exp]) (if v v undefined))]
[(_ exp exps ...) (let ([v exp])
(if v
v
(or-undef exps ...)
(or-undef exps ...)))]))
(define-syntax when
(syntax-rules ()
[(_ test body ...) (if test (begin body ...))]))
(define-syntax unless
(syntax-rules ()
[(_ test body ...) (if (not test) (begin body ...))]))
(define (ormap proc lst)
(and (pair? lst)
(or (proc (car lst)) (ormap proc (cdr lst)))))
(define (andmap proc lst)
(or (null? lst)
(and (proc (car lst)) (andmap proc (cdr lst)))))
(define (caar v)
(car (car v)))
(define (cdar v)
(cdr (car v)))
(define (cadr v)
(car (cdr v)))
(define (cddr v)
(cdr (cdr v)))
(define (caddr v)
(car (cddr v)))
(define (cdddr v)
(cdr (cddr v)))
(define (cadddr v)
(car (cdddr v)))
(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))
(split-list (append acc (list (car lst))) (cdr lst))))
(define frp:apply
(lambda (fn . args)
(if (behavior? args)
(super-lift
(lambda (args)
(apply apply fn args))
args)
(apply apply fn 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 ...)
(let ([v exp])
(vcase v clause ...))]))
(define-syntax vcase
(syntax-rules (else)
[(_ v [else exp ...])
(begin exp ...)]
[(_ v [dl exp ...])
(if (lift #t memv v (quote dl))
(begin exp ...))]
[(_ v [dl exp ...] clause ...)
(if (lift #t memv v (quote dl))
(begin exp ...)
(vcase v clause ...))]))
(define map
(case-lambda
[(f l) (if (pair? l)
(cons (f (car l)) (map f (cdr l)))
null)]
[(f l1 l2) (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))
(cons (apply f (car l) (map car ls)) (apply map f (cdr l) (map cdr ls)))
null)]))
(define (frp:length lst)
(cond
[(pair? lst) (lift #t add1 (frp:length (cdr lst)))]
[(null? lst) 0]
[else (error 'length (format "expects list, given ~a" lst))]))
(define (reverse lst)
(let loop ([lst lst] [acc ()])
(if (pair? lst)
(loop (cdr lst) (cons (car lst) acc))
acc)))
(provide cond
and
or
or-undef
when
unless
map
ormap
andmap
caar
cadr
cddr
caddr
cdddr
cadddr
cddddr
;case
build-path
collection-path
list-ref
(rename frp:case case)
(rename frp:apply apply)
(rename frp:length length)
reverse
(lifted + - * / =
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
sub1 sqrt not number? string? zero? min max modulo
string->number void? rational? char? char-upcase char-ci>=? char-ci<=?
string>=? char-upper-case? char-alphabetic?
string<? string-ci=? string-locale-ci>?
string-locale-ci<? string-locale-ci=? atan asin acos exact? magnitude imag-part
real-part numerator abs log lcm gcd arithmetic-shift integer-sqrt make-rectangular
complex? char>? char<? char=?
char-numeric? date-time-zone-offset list->string substring string->list
string-ci<? string-ci>=? string<=? string-ci<=? string>? string-locale<? string=?
string-length string-ref
floor angle round
ceiling real? date-hour procedure? procedure-arity
rationalize date-year-day date-week-day date? date-dst? date-year date-month date-day
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
seconds->date
expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
exn:fail?
list->vector make-vector vector-set!)
(rename eq? mzscheme:eq?)
make-exn:fail current-inspector make-inspector
make-namespace namespace? namespace-symbol->identifier namespace-variable-value
namespace-set-variable-value! namespace-undefine-variable! namespace-mapped-symbols
parameterize current-seconds current-milliseconds current-inexact-milliseconds
call-with-values make-parameter
null
gensym collect-garbage
error set! printf fprintf current-error-port for-each void
procedure-arity-includes? raise-type-error raise thread
current-continuation-marks
raise-mismatch-error require-for-syntax define-syntax syntax-rules syntax-case
; set-eventspace
;install-errortrace-key
(lifted:nonstrict format)
print-struct
;lambda
;case-lambda
define
let
let*
values
let*-values
let-values
define-values
begin
begin0
quote
unquote
unquote-splicing
syntax
let/ec
with-handlers
delay
force
random
sleep
read-case-sensitive
file-exists?
with-input-from-file
read
; null
; make-struct-field-mutator
)
; from core
(provide (all-from (lib "mzscheme-core.ss" "frtime")))
)

277
collects/frtime/struct.ss Normal file
View File

@ -0,0 +1,277 @@
(module struct mzscheme
(require (lib "etc.ss")
(lib "stx.ss" "syntax"))
(require-for-template mzscheme)
(provide build-struct-names
build-struct-generation
build-struct-expand-info
struct-declaration-info?
generate-struct-declaration
generate-delayed-struct-declaration)
;; build-struct-names : id (list-of id) bool bool -> (list-of id)
(define build-struct-names
(opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f])
(let ([name (symbol->string (syntax-e name-stx))]
[fields (map symbol->string (map syntax-e fields))]
[+ string-append])
(map (lambda (s)
(datum->syntax-object name-stx (string->symbol s) srcloc-stx))
(append
(list
(+ "struct:" name)
(+ "make-" name)
(+ name "?"))
(let loop ([l fields])
(if (null? l)
null
(append
(if omit-sel?
null
(list (+ name "-" (car l))))
(if omit-set?
null
(list (+ "set-" name "-" (car l) "!")))
(loop (cdr l))))))))))
(define build-struct-generation
(opt-lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
[immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
(let ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
(build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list
immutable-positions mk-rec-prop-list))))
(define build-struct-generation*
(opt-lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
[immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
(let ([num-fields (length fields)]
[acc/mut-makers (let loop ([l fields][n 0])
(if (null? l)
null
(let ([mk-one
(lambda (acc?)
(list
`(,(if acc?
'frp:make-struct-field-accessor
'frp:make-struct-field-mutator)
,(if acc? 'acc 'mut)
,n ',(car l))))])
(append
(if omit-sel?
null
(mk-one #t))
(if omit-set?
null
(mk-one #f))
(loop (cdr l) (add1 n))))))]
[extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)])
`(let-values ([(struct: make- ? acc mut)
(frp:make-struct-type ',name ,super-type ,num-fields 0 #f ,prop-value-list #f #f ,immutable-positions)])
(values struct:
make-
?
,@acc/mut-makers)))))
(define build-struct-expand-info
(lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
(let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)])
(build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters))))
(define build-struct-expand-info*
(lambda (names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)
(let* ([flds (cdddr names)]
[every-other (lambda (l)
(let loop ([l l])
(cond
[(null? l) null]
[(null? (cdr l)) (list (car l))]
[else (cons (car l) (loop (cddr l)))])))]
[add-#f (lambda (omit? base)
(if omit?
(if (let loop ([l base])
(cond
[(null? l) #t]
[(not (car l)) #f]
[else (loop (cdr l))]))
(append base '(#f)))
base))]
[qs (lambda (x) (if (eq? x #t)
x
(and x `((syntax-local-certifier) (quote-syntax ,x)))))])
`(list-immutable
,(qs (car names))
,(qs (cadr names))
,(qs (caddr names))
(list-immutable
,@(reverse (if omit-sel?
null
(map qs (if omit-set? flds (every-other flds)))))
,@(map qs (add-#f omit-sel? base-getters)))
(list-immutable
,@(reverse (if omit-set?
null
(map qs (if omit-sel?
flds
(every-other (if (null? flds)
null
(cdr flds)))))))
,@(map qs (add-#f omit-set? base-setters)))
,(qs base-name)))))
(define (struct-declaration-info? x)
(define (identifier/#f? x)
(or (not x)
(identifier? x)))
(define (id/#f-list? id? x)
(or (null? x)
(and (pair? x)
(if (null? (cdr x))
(identifier/#f? (car x))
(and (id? (car x))
(id/#f-list? id? (cdr x)))))))
(and (list? x)
(= (length x) 6)
(identifier/#f? (car x))
(identifier/#f? (cadr x))
(identifier/#f? (caddr x))
(id/#f-list? identifier? (list-ref x 3))
(id/#f-list? identifier/#f? (list-ref x 4))
(or (eq? #t (list-ref x 5)) (identifier/#f? (list-ref x 5)))))
;; ----------------------------------------
(define struct-info-type-id car)
(define struct-info-constructor-id cadr)
(define struct-info-predicate-id caddr)
(define struct-info-accessor-ids cadddr)
(define struct-info-mutator-ids (lambda (x) (list-ref x 4)))
(define (get-stx-info orig-stx super-id defined-names gen-expr?)
;; Looks up super info, if needed, and builds compile-time info for the
;; new struct; called by all three forms, but does only half the work
;; if `defined-names' is #f.
;; If `expr?' is #t, then generate an expression to build the info,
;; otherwise build the info directly.
(let ([qs (if gen-expr? (lambda (x) #`((syntax-local-certifier) (quote-syntax #,x))) values)]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(when super-id
;; Did we get valid super-info ?
(when (or (not (struct-declaration-info? super-info))
(not (struct-info-type-id super-info)))
(raise-syntax-error
#f
(if (struct-declaration-info? super-info)
"parent struct information does not include a type for subtyping"
(format "parent struct type not defined~a"
(if super-info
(format " (~a does not name struct type information)"
(syntax-e super-id))
"")))
orig-stx
super-id)))
;; Generate the results:
(values
super-info
(if defined-names
(let-values ([(initial-gets initial-sets)
(if super-info
(values (map qs (struct-info-accessor-ids super-info))
(map qs (struct-info-mutator-ids super-info)))
(values null null))]
[(fields) (cdddr defined-names)]
[(wrap) (if gen-expr? (lambda (x) #`(list-immutable #,@x)) values)])
(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(apply
list-immutable
(append (map qs (every-other fields))
initial-gets)))
(wrap
(apply
list-immutable
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t))))
#f))))
(define (make-core make-make-struct-type orig-stx defined-names super-info name field-names)
#`(let-values ([(type maker pred access mutate)
#,(make-make-struct-type orig-stx name defined-names super-info)])
(values type maker pred
#,@(let loop ([field-names field-names][n 0])
(if (null? field-names)
null
(list* #`(make-struct-field-accessor access #,n '#,(car field-names))
#`(make-struct-field-mutator mutate #,n '#,(car field-names))
(loop (cdr field-names) (add1 n))))))))
(define (generate-struct-declaration orig-stx
name super-id field-names
context
make-make-struct-type
continue-macro-id continue-data)
(let ([defined-names (build-struct-names name field-names #f #f name)]
[delay? (and (not (memq context '(module top-level expression)))
super-id)])
(let-values ([(super-info stx-info)
(if delay?
(values #f #f)
(get-stx-info orig-stx super-id defined-names #t))])
(let ([result
#`(begin
(define-values
#,defined-names
#,(if delay?
#`(begin0 ;; the `begin0' guarantees that it's an expression
(#,continue-macro-id #,orig-stx #,name #,super-id
#,defined-names #,field-names
#,continue-data))
(make-core make-make-struct-type orig-stx defined-names super-info name field-names)))
(define-syntaxes (#,name)
#,(if delay?
#`(let-values ([(super-info stx-info)
(get-stx-info (quote-syntax ,orig-stx)
(quote-syntax ,super-id)
(list #,@(map (lambda (x)
#`(quote-syntax #,x))
defined-names))
#f
values)])
stx-info)
stx-info)))])
(if super-id
(syntax-property result
'disappeared-use
(syntax-local-introduce super-id))
result)))))
(define (generate-delayed-struct-declaration stx make-make-make-struct-type)
(syntax-case stx ()
[(_ orig-stx name super-id defined-names field-names continue-data)
(let-values ([(super-info stx-info) (get-stx-info #'orig-stx #'super-id #f #f)])
(make-core (make-make-make-struct-type #'continue-data)
#'orig-stx
(syntax->list #'defined-names)
super-info
#'name
(syntax->list #'field-names)))])))