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

Big Commit that introduces the freeze in demos relying on animation

Browse Source
This commit is contained in:
Patrick Mahoney 2012-08-16 18:09:13 -04:00 committed by Gregory Cooper
parent 489d21520e
commit 0ef9104a52
21 changed files with 217 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/frtime/animation.rkt
View File

@ -1,19 +1,26 @@
(module animation frtime
(require (all-except frtime/animation/graphics
(require (except-in frtime/animation/graphics
make-posn posn-x posn-y make-rgb)
(lifted frtime/animation/graphics
posn-x posn-y make-posn make-rgb)
(for-syntax racket/base (only-in racket/function identity))
(lifted (only-in frtime/animation/graphics posn-x)
posn-x)
(lifted (only-in frtime/animation/graphics posn-y)
posn-y)
(lifted (only-in frtime/animation/graphics make-posn)
make-posn)
(lifted (only-in frtime/animation/graphics make-rgb) make-rgb)
racket/match
(as-is:unchecked frtime/lang-ext lift)
racket/class
frtime/frlibs/list
frtime/frlibs/etc
frtime/frlibs/math
#;(rename mzscheme mz:define-struct define-struct))
#;(rename-in racket [define-struct mz:define-struct]))
(require-for-syntax (only racket/base build-list)
(only racket/function identity))
(require (for-syntax (only-in racket/base build-list)
(only-in racket/function identity)))
(open-graphics)
@ -76,7 +83,7 @@
(syntax-case stx ()
[(_ name (field ...))
(with-syntax
([ctor-name (datum->syntax-object stx (string->symbol (format "make-~a" (syntax-e #'name))))]
([ctor-name (datum->syntax stx (string->symbol (format "make-~a" (syntax-e #'name))))]
[(accessor-name ...)
(map (lambda (fd)
(string->symbol (format "~a-~a" (syntax-e #'name) (syntax-e fd))))
@ -376,6 +383,6 @@
(make-posn (integral (posn-x p)) (integral (posn-y p))))
(provide
(all-defined-except pixmap window draw-list l d
(except-out (all-defined-out) pixmap window draw-list l d
make-wave-state wave-state-hz wave-state-offset)
(all-from frtime/animation/graphics)))
(all-from-out frtime/animation/graphics)))

8
collects/frtime/frlibs/etc.rkt
View File

@ -1,12 +1,14 @@
(module etc frtime/frtime-lang-only
(require setup/main-collects)
(require-for-syntax syntax/kerncase
(require (for-syntax
racket/base
syntax/kerncase
syntax/stx
syntax/name
syntax/context
setup/main-collects
mzlib/private/stxset)
mzlib/private/stxset))
(provide true false
boolean=? symbol=?
@ -314,7 +316,7 @@
(let loop ([tests tests])
(unless (null? (cdr tests))
(when (and (identifier? (car tests))
(module-identifier=? (quote-syntax else) (car tests)))
(free-identifier=? (quote-syntax else) (car tests)))
(raise-syntax-error
#f
"else is not in last clause"

19
collects/frtime/frlibs/list.rkt
View File

@ -1,11 +1,16 @@
(module list frtime/frtime-lang-only
(require
(lifted racket/base sort)
(lifted racket/list
fifth sixth seventh eighth
last-pair)
(rename racket/list empty empty))
(lifted (only-in racket/base sort) sort)
(lifted (only-in racket/list fifth)
fifth)
(lifted (only-in racket/list sixth) sixth)
(lifted (only-in racket/list seventh) seventh)
(lifted (only-in racket/list eighth) eighth)
(lifted (only-in racket/list last-pair) last-pair)
(rename-in (except-in racket/list first rest second third fourth empty? cons? fifth sixth seventh eighth last-pair) [empty empty]))
(define first car)
(define rest cdr)
@ -21,7 +26,7 @@
[(item list equal?)
(let loop ([list list])
(cond
[(null? list) ()]
[(null? list) '()]
[(equal? item (car list)) (cdr list)]
[else (cons (car list)
(loop (cdr list)))]))])])
@ -164,4 +169,4 @@
(define (cons? x) (pair? x))
(provide (all-defined) empty))
(provide (all-defined-out) empty))

13
collects/frtime/frp-snip.rkt
View File

@ -1,11 +1,8 @@
#lang scheme/base
(require scheme/class
(only-in mzlib/string expr->string)
scheme/list
scheme/port
#lang racket/base
(require racket/class
racket/list
racket/port
framework
;; FRP requires
frtime/core/frp
@ -50,7 +47,7 @@
[(event-set? tmp) (format "#<event (last: ~a@~a)>"
(event-set-events tmp) (event-set-time tmp))]
[(undefined? tmp) "<undefined>"]
[else (expr->string tmp)])))]
[else (number->string tmp)])))]
[(bhvr super-render-fun)
(get-rendering (value-now bhvr) super-render-fun)]))

10
collects/frtime/frtime-big.rkt
View File

@ -5,8 +5,8 @@
frtime/frlibs/math
frtime/frlibs/date)
(provide (all-from frtime/frtime)
(all-from frtime/frlibs/list)
(all-from frtime/frlibs/etc)
(all-from frtime/frlibs/math)
(all-from frtime/frlibs/date)))
(provide (all-from-out frtime/frtime)
(all-from-out frtime/frlibs/list)
(all-from-out frtime/frlibs/etc)
(all-from-out frtime/frlibs/math)
(all-from-out frtime/frlibs/date)))

8
collects/frtime/frtime-lang-only.rkt
View File

@ -1,6 +1,6 @@
(module frtime-lang-only "lang-utils.rkt"
(require (only frtime/lang-ext undefined? signal? value-now lift))
(require (as-is:unchecked frtime/core/frp
(require (only-in frtime/lang-ext undefined? signal? value-now lift))
(require (as-is:unchecked (except-in frtime/core/frp undefined? undefined)
event-set? signal-value))
(define (value-nowable? x)
@ -13,5 +13,5 @@
(pred v))))
(provide value-nowable? behaviorof
(all-from "lang-utils.rkt")
(all-from-except frtime/lang-ext lift)))
(all-from-out "lang-utils.rkt")
(all-from-out frtime/lang-ext)))

10
collects/frtime/frtime.rkt
View File

@ -1,7 +1,7 @@
(module frtime "lang-utils.rkt"
(require (all-except "lang-ext.rkt" lift deep-value-now))
(require (except-in "lang-ext.rkt" lift deep-value-now))
(require "frp-snip.rkt")
(require (as-is:unchecked frtime/core/frp
(require (as-is:unchecked (except-in frtime/core/frp undefined undefined?)
event-set? signal-value))
(define (value-nowable? x)
@ -14,6 +14,6 @@
(pred v))))
(provide value-nowable? behaviorof
(all-from "lang-ext.rkt")
(all-from "lang-utils.rkt")
(all-from "frp-snip.rkt")))
(all-from-out "lang-ext.rkt")
(all-from-out "lang-utils.rkt")
(all-from-out "frp-snip.rkt")))

4
collects/frtime/gui.rkt
View File

@ -1,6 +1,6 @@
(module gui frtime
(require
(all-except mzlib/etc rec)
(except-in mzlib/etc rec)
frtime/gui/fred)
(define frame (new ft-frame% [label "GUI"] [min-height 150] [min-width 200] [shown #t]))
@ -44,4 +44,4 @@
(set! frame (new ft-frame% [label "GUI"] [min-height 150] [min-width 200]
[shown #t])))))))
(provide (all-defined)))
(provide (all-defined-out)))

3
collects/frtime/gui/aux-mixin-macros.rkt
View File

@ -1,6 +1,7 @@
(module aux-mixin-macros frtime
(require "mixin-macros.rkt")
(require racket/class)
(require (for-syntax racket/base))
;; consider taking out setter
@ -70,4 +71,4 @@
[(_ src)
src]))
(provide (all-defined)))
(provide (all-defined-out)))

2
collects/frtime/gui/demo/bindec.rkt
View File

@ -1,6 +1,6 @@
#lang frtime
(require frtime/gui/simple)
(require (rename mred horizontal-panel% horizontal-panel%))
(require (rename-in mred [horizontal-panel% horizontal-panel%]))
; just change this to change the range of the binary/decimal converter
(define SIZE 10)

2
collects/frtime/gui/demo/instr.rkt
View File

@ -1,6 +1,6 @@
#lang frtime
(require frtime/gui/mixin-macros frtime/gui/aux-mixin-macros)
(require mzlib/class) ; require class utilities
(require racket/class) ; require class utilities
(require mred) ; require base mred library

10
collects/frtime/gui/fred.rkt
View File

@ -4,7 +4,7 @@
racket/class
racket/string
texpict/mrpict
(all-except mred send-event)
mred
framework)
@ -322,7 +322,7 @@
menu-item%)))
(provide (all-defined)
(all-from racket/class)
(all-from "mixin-macros.rkt")
(all-from "aux-mixin-macros.rkt")))
(provide (all-defined-out)
(all-from-out racket/class)
(all-from-out "mixin-macros.rkt")
(all-from-out "aux-mixin-macros.rkt")))

4
collects/frtime/gui/mixin-macros.rkt
View File

@ -1,5 +1,7 @@
(module mixin-macros frtime
(require racket/class)
(require racket/class
(for-syntax racket/base))
(define-syntax events->callbacks
(lambda (stx)

9
collects/frtime/gui/simple.rkt
View File

@ -2,7 +2,8 @@
(require "fred.rkt"
racket/class
(rename mred frame% frame%))
(rename-in mred [frame% frame%])
(for-syntax racket/base))
(define widget (lambda (x) x))
(define value-b (lambda (x) (send x get-value-b)))
@ -48,6 +49,6 @@
(provide (all-defined)
(all-from "fred.rkt")
(all-from racket/class)))
(provide (all-defined-out)
(all-from-out "fred.rkt")
(all-from-out racket/class)))

141
collects/frtime/lang-core.rkt
View File

@ -1,14 +1,14 @@
(module lang-core mzscheme
(require-for-syntax (only syntax/struct build-struct-names build-struct-generation build-struct-expand-info)
(only racket/base foldl)
(only racket/list empty))
(require (only racket/list cons? first second rest empty empty?)
(only racket/base vector-ref build-vector build-list)
(only racket/function identity)
(only mzlib/etc opt-lambda)
(only frtime/core/frp super-lift undefined undefined? behavior? do-in-manager-after do-in-manager proc->signal set-signal-thunk! register unregister iq-enqueue value-now/no-copy
(module lang-core racket
(require (for-syntax (only-in syntax/struct build-struct-names build-struct-generation build-struct-expand-info)
(only-in racket/base foldl)
(only-in racket/list empty)))
(require (only-in racket/list cons? first second rest empty empty?)
(only-in racket/base vector-ref build-vector build-list)
(only-in racket/function identity)
(only-in mzlib/etc opt-lambda)
(only-in frtime/core/frp super-lift undefined undefined? behavior? do-in-manager-after do-in-manager proc->signal set-signal-thunk! register unregister iq-enqueue value-now/no-copy
signal? signal-depth signal:switching? signal-value value-now signal:compound? signal:compound-content signal:switching-current signal:switching-trigger set-cell!)
(only frtime/lang-ext lift new-cell switch ==> changes deep-value-now))
(only-in frtime/lang-ext lift new-cell switch ==> changes deep-value-now))
#| (VECTOR-ANY <pred?> <vector>) -> value
;;; Apply PRED? to each element in VECTOR ...; if PRED?
@ -63,7 +63,7 @@
(define (frp:copy-list lst)
(frp:if (null? lst)
()
'()
(frp:cons (frp:car lst) (frp:copy-list (frp:cdr lst)))))
(define-syntax frp:let-values
@ -134,9 +134,9 @@
(cond
[(assq obj table) => second]
[(behavior? obj)
(case (hash-table-get deps obj 'absent)
[(absent) (hash-table-put! deps obj 'new)]
[(old) (hash-table-put! deps obj 'alive)]
(case (hash-ref deps obj 'absent)
[(absent) (hash-set! deps obj 'new)]
[(old) (hash-set! deps obj 'alive)]
[(new) (void)])
(deep-value-now/update-deps (signal-value obj) deps
(cons (list obj (signal-value obj)) table))]
@ -191,9 +191,9 @@
(define (deep-cdr-value-now/update-deps obj deps table)
(cond
[(behavior? obj)
(case (hash-table-get deps obj 'absent)
[(absent) (hash-table-put! deps obj 'new)]
[(old) (hash-table-put! deps obj 'alive)]
(case (hash-ref deps obj 'absent)
[(absent) (hash-set! deps obj 'new)]
[(old) (hash-set! deps obj 'alive)]
[(new) (void)])
(deep-cdr-value-now/update-deps (signal-value obj) deps table)]
[(cons? obj)
@ -206,20 +206,20 @@
(let ([rtn (proc->signal void)])
(set-signal-thunk!
rtn
(let ([deps (make-hash-table)])
(let ([deps (make-hash)])
(lambda ()
(begin0
(deep-cdr-value-now/update-deps obj deps empty)
(hash-table-for-each
(hash-for-each
deps
(lambda (k v)
(case v
[(new) (hash-table-put! deps k 'old)
[(new) (hash-set! deps k 'old)
(register rtn k)
(do-in-manager
(iq-enqueue rtn))]
[(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
[(alive) (hash-set! deps k 'old)]
[(old) (hash-remove! deps k)
(unregister rtn k)])))))))
(do-in-manager
(iq-enqueue rtn))
@ -230,18 +230,18 @@
(let ([rtn (proc->signal void)])
(set-signal-thunk!
rtn
(let ([deps (make-hash-table)])
(let ([deps (make-hash)])
(lambda ()
(begin0
(deep-value-now/update-deps obj deps empty)
(hash-table-for-each
(hash-for-each
deps
(lambda (k v)
(case v
[(new) (hash-table-put! deps k 'old)
[(new) (hash-set! deps k 'old)
(register rtn k)]
[(alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
[(alive) (hash-set! deps k 'old)]
[(old) (hash-remove! deps k)
(unregister rtn k)])))))))
(do-in-manager
(iq-enqueue rtn))
@ -251,7 +251,7 @@
(let ([rtn (proc->signal void)])
(set-signal-thunk!
rtn
(let ([deps (make-hash-table)])
(let ([deps (make-hash)])
(lambda ()
(begin0
(let/ec esc
@ -259,23 +259,23 @@
(proc (lambda (obj)
(if (behavior? obj)
(begin
(case (hash-table-get deps obj 'absent)
[(absent) (hash-table-put! deps obj 'new)
(case (hash-ref deps obj 'absent)
[(absent) (hash-set! deps obj 'new)
(let ([o-depth (signal-depth rtn)])
(register rtn obj)
(when (> (signal-depth rtn) o-depth)
(iq-enqueue rtn)
(esc #f)))]
[(old) (hash-table-put! deps obj 'alive)]
[(old) (hash-set! deps obj 'alive)]
[(new) (void)])
(value-now obj))
obj)));)
(hash-table-for-each
(hash-for-each
deps
(lambda (k v)
(case v
[(new alive) (hash-table-put! deps k 'old)]
[(old) (hash-table-remove! deps k)
[(new alive) (hash-set! deps k 'old)]
[(old) (hash-remove! deps k)
(unregister rtn k)])))))))))
(iq-enqueue rtn)
rtn))
@ -333,7 +333,7 @@
(define frp:append
(case-lambda
[() ()]
[() '()]
[(lst) lst]
[(lst1 lst2 . lsts)
(list-match lst1
@ -435,7 +435,7 @@
(define (ensure-no-signal-args val name)
(if (procedure? val)
(when (procedure? val)
(lambda args
(cond
[(find signal? args)
@ -463,7 +463,7 @@
(with-syntax ([(fun-name ...) (syntax ids)]
[(tmp-name ...)
(map (lambda (id)
(datum->syntax-object stx (syntax-object->datum id)))
(datum->syntax stx (syntax->datum id)))
(generate-temporaries (syntax ids)))])
(syntax
(begin
@ -471,12 +471,12 @@
(define (tmp-name . args)
(apply lift #t fun-name args))
...
(provide (rename tmp-name fun-name) ...))))]
(provide (rename-out [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)))
(datum->syntax stx (syntax->datum id)))
(generate-temporaries (syntax ids)))])
(syntax
(begin
@ -484,7 +484,7 @@
(define (tmp-name . args)
(apply lift #f fun-name args))
...
(provide (rename tmp-name fun-name) ...))))]
(provide (rename-out [tmp-name fun-name]) ...))))]
[provide-spec
(syntax (begin clause ... (provide provide-spec)))])]))
(syntax (begin))
@ -493,7 +493,7 @@
(define-syntax (frp:require stx)
(define (generate-temporaries/loc st ids)
(map (lambda (id)
(datum->syntax-object stx (syntax-object->datum id)))
(datum->syntax stx (syntax->datum id)))
(generate-temporaries ids)))
(syntax-case stx ()
[(_ . clauses)
@ -507,7 +507,7 @@
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
#'(begin
clause ...
(require (rename module tmp-name fun-name) ...)
(require (rename-in module [fun-name tmp-name]) ...)
(define (fun-name . args)
(apply lift #f tmp-name args))
...))]
@ -516,18 +516,18 @@
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
#'(begin
clause ...
(require (rename module tmp-name fun-name) ...)
(require (rename-in module [fun-name tmp-name]) ...)
(define (fun-name . args)
(apply lift #t tmp-name args))
...))]
[(as-is:unchecked module id ...)
(syntax (begin clause ... (require (rename module id id) ...)))]
(syntax (begin clause ... (require (rename-in 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) ...)
(require (rename-in module [fun-name tmp-name]) ...)
(define fun-name (ensure-no-signal-args tmp-name 'fun-name))
...))]
[require-spec
@ -545,7 +545,12 @@
#%plain-module-begin
#%module-begin
#%top-interaction
only-in
except-in
rename-in
all-from-out
all-defined-out
except-out
raise-reactivity
raise-list-for-apply
@ -555,25 +560,25 @@
frp:copy-list
frp:->boolean
(rename public-dvn deep-value-now)
(rename frp:if if)
(rename frp:lambda lambda)
(rename frp:case-lambda case-lambda)
(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)))
(rename-out [public-dvn deep-value-now])
(rename-out [frp:if if])
(rename-out [frp:lambda lambda])
(rename-out [frp:case-lambda case-lambda])
(rename-out [frp:letrec letrec])
(rename-out [frp:cons cons])
(rename-out [frp:car car])
(rename-out [frp:cdr cdr])
(rename-out [frp:list list])
(rename-out [frp:list? list?])
(rename-out [frp:list* list*])
(rename-out [frp:null? null?])
(rename-out [frp:pair? pair?])
(rename-out [frp:append append])
(rename-out [frp:vector vector])
(rename-out [frp:vector-ref vector-ref])
(rename-out [frp:make-struct-type make-struct-type])
(rename-out [frp:make-struct-field-accessor make-struct-field-accessor])
(rename-out [frp:make-struct-field-mutator make-struct-field-mutator])
(rename-out [frp:define-struct define-struct])
(rename-out [frp:provide provide])
(rename-out [frp:require require])))

46
collects/frtime/lang-utils.rkt
View File

@ -1,7 +1,6 @@
(module lang-utils "lang-core.rkt"
(require (only mzscheme let define-syntax define apply procedure-arity syntax-object->datum with-input-from-file require-for-syntax make-namespace expand-path collection-path begin syntax-rules)
(all-except racket
(require (only-in racket let define-syntax define apply procedure-arity syntax->datum with-input-from-file for-syntax make-empty-namespace cleanse-path collection-path begin syntax-rules)
(except-in racket
else
module
begin
@ -28,8 +27,7 @@
collection-path
collection-file-path
list-ref
require
collection-path
require
raise-arity-error
procedure-rename
impersonate-procedure
@ -57,13 +55,14 @@
or
cond when unless
map ormap andmap assoc member open-input-file open-output-file open-input-output-file call-with-output-file call-with-input-file with-output-to-file with-input-from-file)
(rename mzscheme mzscheme:if if)
(rename "lang-ext.rkt" lift lift)
(only frtime/core/frp super-lift behavior? value-now)
(rename "lang-ext.rkt" undefined undefined)
(rename "lang-ext.rkt" undefined? undefined?)
racket/class)
(require (only racket/list empty))
(rename-in (only-in mzscheme if) [if mzscheme:if])
(rename-in (only-in "lang-ext.rkt" lift) [lift lift])
(only-in frtime/core/frp super-lift behavior? value-now)
(rename-in "lang-ext.rkt" [undefined undefined])
(rename-in "lang-ext.rkt" [undefined? undefined?])
racket/class
(for-syntax racket/base))
(require (only-in racket/list empty))
(define-syntax (lifted-send stx)
(syntax-case stx ()
@ -277,7 +276,7 @@
(lift #t list->string (raise-reactivity lst)))
(define (reverse lst)
(let loop ([lst lst] [acc ()])
(let loop ([lst lst] [acc '()])
(if (pair? lst)
(loop (cdr lst) (cons (car lst) acc))
acc)))
@ -313,10 +312,11 @@
dont-optimize
list-ref
(rename frp:case case)
(rename frp:apply apply)
(rename frp:length length)
(rename frp:list->string list->string)
(rename-out [frp:case case])
(rename-out [frp:apply apply])
(rename-out [frp:length length])
(rename-out [frp:list->string list->string])
(rename-out [eq? mzscheme:eq?])
reverse
(lifted + - * / =
@ -342,13 +342,13 @@
make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact?
char-whitespace? assq assv memq memv list-tail
seconds->date
expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
expand syntax->datum exn-message continuation-mark-set->list exn-continuation-marks
exn:fail? regexp-match
vector->list list->vector make-vector)
(rename eq? mzscheme:eq?)
make-exn:fail current-inspector make-inspector
make-namespace namespace? namespace-symbol->identifier namespace-variable-value
make-empty-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
@ -357,7 +357,7 @@
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 define-syntaxes syntax-rules syntax-case
raise-mismatch-error for-syntax define-syntax define-syntaxes syntax-rules syntax-case
(lifted:nonstrict format)
print-struct
define
@ -385,7 +385,7 @@
path->complete-path
string->path path->string
bytes->path path->bytes
split-path simplify-path normal-case-path expand-path resolve-path
split-path simplify-path normal-case-path cleanse-path resolve-path
path-replace-suffix
current-directory
exit
@ -402,6 +402,6 @@
read)
; from core
(provide (all-from "lang-core.rkt"))
(provide (all-from-out "lang-core.rkt"))
)

7
collects/frtime/lang.rkt
View File

@ -1,7 +1,6 @@
(module lang frtime/lang-utils
(require frtime/lang-ext)
(require (as-is:unchecked frtime/core/frp
event-set? signal-value))
(require (as-is:unchecked (except-in frtime/core/frp undefined undefined?) event-set? signal-value))
(define (value-nowable? x)
(or (not (signal? x))
@ -13,5 +12,5 @@
(pred v))))
(provide value-nowable? behaviorof
(all-from frtime/lang-utils)
(all-from-except frtime/lang-ext lift)))
(all-from-out frtime/lang-utils)
(except-out (all-from-out frtime/lang-ext) lift)))

2
collects/frtime/main.rkt
View File

@ -1,2 +1,2 @@
(module main "frtime-big.rkt"
(provide (all-from "frtime-big.rkt")))
(provide (all-from-out "frtime-big.rkt")))

32
collects/frtime/opt/frtime-opt-lang.rkt
View File

@ -1,9 +1,11 @@
;; This module defines all the functions necessary to write FrTime programs,
;; as well as their lowered equivalents. It doesn't know how to perform
;; optimization, though -- that is left to the frtime-opt module.
(module frtime-opt-lang mzscheme
(require (prefix frtime: frtime/frtime))
(require-for-syntax frtime/opt/lowered-equivs)
(module frtime-opt-lang racket
(require (prefix-in frtime: frtime/frtime))
(require (for-syntax racket/base frtime/opt/lowered-equivs))
(require (only-in frtime/frtime-big event-receiver send-event
nothing null collect-garbage))
;; Export a function that is just a lifted version of a standard
;; function (with the same name).
@ -12,9 +14,9 @@
(syntax-case stx ()
[(_ MOD FUNC)
(let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
#`(begin (require (rename frtime/frtime-big lifted-func FUNC))
(provide (rename lifted-func FUNC))
(require (rename MOD #,lowered-equiv-id FUNC))
#`(begin (require (rename-in frtime/frtime-big [FUNC lifted-func]))
(provide (rename-out [lifted-func FUNC]))
(require (rename-in MOD [FUNC #,lowered-equiv-id]))
(provide #,lowered-equiv-id)))]
[(_ MOD FUNC FUNCS ...)
#`(begin (provide/lifted MOD FUNC)
@ -24,7 +26,7 @@
(syntax-case stx ()
[(_ FUNC)
(let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
#`(begin (require (only frtime/frtime-big FUNC))
#`(begin (require (only-in frtime/frtime-big FUNC))
;; note: the definition is necessary here because otherwise the lowered
;; equiv doesn't become part of the module's namespace, and there's
;; no way to find the list of identifiers exported by a module other
@ -40,13 +42,13 @@
(define-syntax provide/no-equiv
(syntax-rules ()
[(_ FUNC)
(begin (require (rename frtime/frtime-big func FUNC))
(provide (rename func FUNC)))]
(begin (require (rename-in frtime/frtime-big [FUNC func]))
(provide (rename-out [func FUNC])))]
[(_ FUNC FUNCS ...)
(begin (provide/no-equiv FUNC)
(provide/no-equiv FUNCS ...))]))
(provide/lifted mzscheme
(provide/lifted racket
;; equality
eq? equal? eqv?
@ -106,13 +108,13 @@
with-handlers
;; syntax
expand #;expand-syntax syntax syntax-object->datum syntax-case syntax-rules
expand #;expand-syntax syntax syntax->datum syntax-case syntax-rules
;; paths
path? path-string? string->path path->string
bytes->path path->bytes build-path absolute-path? relative-path?
complete-path? path->complete-path resolve-path path-replace-suffix
expand-path simplify-path normal-case-path split-path
cleanse-path simplify-path normal-case-path split-path
;; I/O
printf fprintf file-exists? #;link-exists? #;make-file-or-directory-link
@ -169,7 +171,7 @@
lambda quote unquote unquote-splicing make-parameter parameterize
procedure-arity-includes? dynamic-require)
(provide #%app #%top #%datum require require-for-syntax provide define)
(provide #%app #%top #%datum require for-syntax provide define)
(provide display) ;; for debugging
#;(require frtime/frlibs/list
@ -186,7 +188,7 @@
;; accessor functions
(define-syntax (my-define-struct stx)
(define (make-lowered-accessor struct-id field-id)
(let* ([upper-id (datum->syntax-object
(let* ([upper-id (datum->syntax
field-id
(string->symbol
(format "~s-~s"
@ -210,5 +212,5 @@
#`(begin
(frtime:define-struct STRUCT (FIELD ...) . REST)
#,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]))
(provide (rename my-define-struct define-struct))
(provide (rename-out [my-define-struct define-struct]))
)

56
collects/frtime/opt/frtime-opt.rkt
View File

@ -4,17 +4,17 @@
;; perform optimization of FrTime functions. The rest of the language
;; (i.e. all the functions needed to actually write FrTime programs) is
;; provided by the frtime-opt-lang module, which is automatically imported.
(module frtime-opt mzscheme
(provide (rename my-module-begin #%module-begin)
(module frtime-opt racket
(provide (rename-out [my-module-begin #%module-begin])
#%app #%top #%datum optimize-expr optimize-module dont-optimize)
(require-for-syntax frtime/opt/lowered-equivs)
(require-for-syntax (only srfi/1 lset-union lset-difference every))
(require-for-syntax mzlib/list)
(require (only frtime/core/frp super-lift undefined undefined?))
(require (rename frtime/lang-ext frtime:lift lift)
(rename frtime/lang-core frtime:if if)
(only frtime/lang-core frp:copy-list))
(require (for-syntax frtime/opt/lowered-equivs)
(for-syntax (only-in srfi/1 lset-union lset-difference every))
(for-syntax racket/list))
(require (only-in frtime/core/frp super-lift undefined undefined?))
(require (rename-in (except-in frtime/lang-ext undefined undefined? deep-value-now) [lift frtime:lift])
(rename-in frtime/lang-core [if frtime:if])
(only-in frtime/lang-core frp:copy-list))
; (require mzlib/unit mzlib/unitsig)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -30,18 +30,18 @@
(define-for-syntax (safe-module-identifier=? id1 id2)
(and (identifier? id1)
(identifier? id2)
(module-identifier=? id1 id2)))
(free-identifier=? id1 id2)))
;; Convert a syntax-object to a datum and back again. This replaces all
;; the context information. It's necessary to get generated require
;; statements to work, for some reason.
;; See http://list.cs.brown.edu/pipermail/plt-scheme/2006-July/014163.html
(define-for-syntax (so->d->so ref-stx stx)
(datum->syntax-object ref-stx (syntax-object->datum stx)))
(datum->syntax ref-stx (syntax->datum stx)))
;; Convert a syntactic module reference to a module-path-index
(define-for-syntax (module-stx-to-path-index mod-stx)
(let ([mod (syntax-object->datum mod-stx)])
(let ([mod (syntax->datum mod-stx)])
(if (symbol? mod)
mod
(module-path-index-join mod #f))))
@ -49,7 +49,7 @@
;; Convert a syntactic module reference to a module-path (this is
;; subtly different from a module-path-index)
(define-for-syntax (module-stx-to-path mod-stx)
(syntax-object->datum mod-stx))
(syntax->datum mod-stx))
;; Does the given module export the given id?
(define-for-syntax (module-exports-id? mod-stx id-stx)
@ -73,7 +73,7 @@
(lambda (id) (not (module-provide-protected? mod-path-index id)))
all-symbols)]
[exported-ids (map
(lambda (symbol) (datum->syntax-object ref-stx symbol))
(lambda (symbol) (datum->syntax ref-stx symbol))
exported-symbols)])
exported-ids))))
@ -81,7 +81,7 @@
;; The variables are projected before evaluating the expression,
;; and the result is then injected into the dataflow graph as a
;; single node.
(require (only frtime/core/frp proc->signal value-now))
(require (only-in frtime/core/frp proc->signal value-now))
(define-syntax (dip stx)
(syntax-case stx (begin)
;; special case: don't dip lone identifiers
@ -259,7 +259,7 @@
(or (free-identifier=? #'LIFTED #'lifted)
(free-identifier=? #'LIFTED #'lifted:nonstrict)))
(let* ([lowered-equiv-id (make-lowered-equiv-id #'ID)]
[strict? (datum->syntax-object #'MOD (free-identifier=? #'LIFTED #'lifted))])
[strict? (datum->syntax #'MOD (free-identifier=? #'LIFTED #'lifted))])
#`(begin
(require #,(so->d->so #'MOD #`(rename MOD #,lowered-equiv-id ID)))
(define (ID . args) (apply frtime:lift #,strict? #,lowered-equiv-id args))
@ -325,7 +325,7 @@
(define-for-syntax (union-id-lists . id-lists)
(foldl (lambda (l1 l2)
(lset-union bound-identifier=? l1 l2))
()
'()
id-lists))
(define-for-syntax (diff-id-lists id-list1 id-list2)
(lset-difference bound-identifier=? id-list1 id-list2))
@ -343,7 +343,7 @@
(append (extract-args #'ID)
(extract-args #'REST))]
[()
()]
'()]
[ELSE
(raise-syntax-error #f "doesn't look like an arg list" stx)]))
@ -368,15 +368,15 @@
(syntax-case stx ()
[ID
(and (identifier? #'ID)
(module-identifier=? old-id #'ID))
(free-identifier=? old-id #'ID))
new-id]
[(X . Y)
(datum->syntax-object
(datum->syntax
stx
(cons (replace-id #'X old-id new-id)
(replace-id #'Y old-id new-id)))]
[()
()]
'()]
[ELSE
stx]))
@ -385,7 +385,7 @@
(syntax-case stx ()
[ID
(and (identifier? #'ID)
(module-identifier=? id #'ID))
(free-identifier=? id #'ID))
#t]
[(X . Y)
(or (refers-to-id? #'X id)
@ -414,8 +414,8 @@
[(BEGIN EXPR ...)
(and (identifier? #'BEGIN)
(or (module-identifier=? #'BEGIN #'begin)
(module-identifier=? #'BEGIN #'begin0)))
(or (free-identifier=? #'BEGIN #'begin)
(free-identifier=? #'BEGIN #'begin0)))
(let* ([optimized-exprs (map (lambda (expr)
(recursively-optimize-expr expr equiv-map #f))
(syntax->list #'(EXPR ...)))]
@ -483,7 +483,7 @@
LOOP_) ARG ...)
(and (identifier? #'LOOP)
(identifier? #'LOOP_)
(module-identifier=? #'LOOP #'LOOP_))
(free-identifier=? #'LOOP #'LOOP_))
(let* ([optimized-args (map (lambda (e)
(recursively-optimize-expr e equiv-map #f))
(syntax->list #'(ARG ...)))]
@ -524,8 +524,8 @@
[(LET-VALUES ((VARS VALS) ...) EXPR ...)
(and (identifier? #'LET-VALUES)
(or (module-identifier=? #'LET-VALUES #'let-values)
(module-identifier=? #'LET-VALUES #'letrec-values)))
(or (free-identifier=? #'LET-VALUES #'let-values)
(free-identifier=? #'LET-VALUES #'letrec-values)))
(let* ([bindings (syntax->list #'(VARS ...))]
[flattened-bindings (apply append (map syntax->list bindings))]
[body #`(begin EXPR ...)]
@ -643,7 +643,7 @@
[ELSE
(raise-syntax-error #f
(format "recursively-lower-expr: unrecognized syntax: ~a" (syntax-object->datum stx))
(format "recursively-lower-expr: unrecognized syntax: ~a" (syntax->datum stx))
stx)]))
;; Optimize a single expression. Raises exn:fail:syntax if the optimized version

2
collects/frtime/opt/lowered-equivs.rkt
View File

@ -1,7 +1,7 @@
;; This module defines all the logic necessary for working with lowered
;; equivalents at the syntactic level. That is, it treats functions simply
;; as syntactic identifiers.
#lang scheme
#lang racket
(provide (except-out (all-defined-out)
module-identifier=?))
(require (only-in srfi/1 any))