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

adjusting big-bang and universe so that they call functions and don't expand into object construction

Browse Source
This commit is contained in:
Matthias Felleisen 2010-10-07 18:49:17 -04:00
parent db0046101c
commit 8ef896431a
8 changed files with 305 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/2htdp/private/check-aux.rkt
View File

@ -1,5 +1,4 @@
#lang racket
#lang scheme
(require htdp/error) (require htdp/error)

111
collects/2htdp/private/keywords.rkt
View File

@ -1,29 +1,40 @@
#lang racket #lang racket
(require (for-syntax "syn-aux.ss") "syn-aux.ss" (require (for-syntax "syn-aux.ss")
"syn-aux.ss"
"syn-aux-aux.ss" "syn-aux-aux.ss"
"check-aux.rkt"
(only-in "universe.rkt" make-bundle)
(rename-in lang/prim (first-order->higher-order f2h))) (rename-in lang/prim (first-order->higher-order f2h)))
(provide (for-syntax AllSpec WldSpec UniSpec)) (provide [for-syntax WldSpec UniSpec])
(define-keywords AllSpec (define-keywords AllSpec '() define-all
;; -- on-tick must specify a tick handler; it may specify a clock-tick rate ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
[on-tick (function-with-arity [on-tick
1 DEFAULT #'#f
except (function-with-arity
[(_ f rate) 1
#'(list except
(proc> 'on-tick (f2h f) 1) [(_ f rate)
(num> 'on-tick rate (lambda (x) (and (real? x) (positive? x))) #'(list
"positive number" "rate"))])] (proc> 'on-tick (f2h f) 1)
(num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
"positive number" "rate"))])]
;; -- state specifies whether to display the current state ;; -- state specifies whether to display the current state
[state (expr-with-check bool> "expected a boolean (show state or not)")] [state
DEFAULT #'#f
(expr-with-check bool> "expected a boolean (show state or not)")]
;; -- check-with must specify a predicate ;; -- check-with must specify a predicate
[check-with (function-with-arity 1)]) [check-with
DEFAULT #'True
(function-with-arity 1)])
(define-keywords WldSpec ; (create-world world0)
(define-keywords WldSpec AllSpec create-world
;; -- on-draw must specify a rendering function; it may specify dimensions ;; -- on-draw must specify a rendering function; it may specify dimensions
[on-draw to-draw [on-draw to-draw
DEFAULT #'#f
(function-with-arity (function-with-arity
1 1
except except
@ -32,32 +43,68 @@
(nat> 'to-draw width "width") (nat> 'to-draw width "width")
(nat> 'to-draw height "height"))])] (nat> 'to-draw height "height"))])]
;; -- on-mouse must specify a mouse event handler ;; -- on-mouse must specify a mouse event handler
[on-mouse (function-with-arity 4)] [on-mouse
DEFAULT #'K
(function-with-arity 4)]
;; -- on-key must specify a key event handler ;; -- on-key must specify a key event handler
[on-key (function-with-arity 2)] [on-key
DEFAULT #'K
(function-with-arity 2)]
;; -- on-release must specify a release event handler ;; -- on-release must specify a release event handler
[on-release (function-with-arity 2)] [on-release
DEFAULT #'K
(function-with-arity 2)]
;; -- on-receive must specify a receive handler ;; -- on-receive must specify a receive handler
[on-receive (function-with-arity 2)] [on-receive
DEFAULT #'#f
(function-with-arity 2)]
;; -- stop-when must specify a predicate; it may specify a rendering function ;; -- stop-when must specify a predicate; it may specify a rendering function
[stop-when (function-with-arity [stop-when
1 DEFAULT #'False
except (function-with-arity
[(_ stop? last-picture) 1
#'(list (proc> 'stop-when (f2h stop?) 1) except
(proc> 'stop-when (f2h last-picture) 1))])] [(_ stop? last-picture)
#'(list (proc> 'stop-when (f2h stop?) 1)
(proc> 'stop-when (f2h last-picture) 1))])]
;; -- should the session be recorded and turned into PNGs and an animated GIF ;; -- should the session be recorded and turned into PNGs and an animated GIF
[record? (expr-with-check bool> "expected a boolean (to record? or not)")] [record?
[name (expr-with-check string> "expected a name (string) for the world")] DEFAULT #'#f
(expr-with-check bool> "expected a boolean (to record? or not)")]
[name
DEFAULT #'#f
(expr-with-check string> "expected a name (string) for the world")]
;; -- register must specify the internet address of a host (e.g., LOCALHOST) ;; -- register must specify the internet address of a host (e.g., LOCALHOST)
[register (expr-with-check ip> "expected a host (ip address)")]) [register
DEFAULT #'#f
(expr-with-check ip> "expected a host (ip address)")])
(define-keywords UniSpec ; (create-universe universe0)
(define-keywords UniSpec AllSpec create-universe
;; -- on-new must specify what happens when a world joins the universe ;; -- on-new must specify what happens when a world joins the universe
[on-new (function-with-arity 2)] [on-new
DEFAULT #'"my-bad"
(function-with-arity 2)]
;; -- on-msg must specify what happens to a message from a world ;; -- on-msg must specify what happens to a message from a world
[on-msg (function-with-arity 3)] [on-msg
DEFAULT #'"my-bad"
(function-with-arity 3)]
;; -- on-disconnect may specify what happens when a world drops out ;; -- on-disconnect may specify what happens when a world drops out
[on-disconnect (function-with-arity 2)] [on-disconnect
;; ******************************************************************
DEFAULT #'(lambda (u w) (make-bundle u '() '()))
;; this is the wrong default function
;; instead of K there should be a function that produces a bundle
(function-with-arity 2)
;; ******************************************************************
]
;; -- to-string specifies how to render the universe as a string for display ;; -- to-string specifies how to render the universe as a string for display
[to-string (function-with-arity 1)]) [to-string
DEFAULT #'#f
(function-with-arity 1)])
(provide new-world)
(define new-world (create-world world0))
(provide new-universe)
(define new-universe (create-universe universe0))

4
collects/2htdp/private/syn-aux-aux.rkt
View File

@ -1,6 +1,6 @@
#lang scheme #lang racket
(require htdp/error) (require htdp/error "check-aux.rkt")
; ;
; ;

137
collects/2htdp/private/syn-aux.rkt
View File

@ -1,53 +1,82 @@
#lang scheme #lang racket
(provide define-keywords (provide define-keywords
;; (define-keywords (name1:identifier ... spec:expr) ...) DEFAULT
;; constraint: the first name is the original name ;; constraint: the first kw is the original one
;; and it is also the name of the field in the class ;; and it is also the name of the field in the class
function-with-arity expr-with-check except err
->args ->args
function-with-arity expr-with-check except err
->kwds-in ->kwds-in
clauses-use-kwd) clauses-use-kwd)
(require (require
(for-template "syn-aux-aux.ss" (for-syntax "syn-aux-aux.rkt" syntax/parse)
scheme (for-template "syn-aux-aux.rkt"
racket
(rename-in lang/prim (first-order->higher-order f2h)))) (rename-in lang/prim (first-order->higher-order f2h))))
(require (for-syntax syntax/parse)) (define-syntax (DEFAULT stx)
(define-syntax (define-keywords stx) (raise-syntax-error 'DEFAULT "used out of context" stx))
(syntax-parse stx
[(define-keywords the-list (kw:identifier ... coerce:expr) ...)
#'(begin
(provide kw ...) ...
(define-syntaxes (kw ...)
(values (lambda (x)
(raise-syntax-error 'kw "used out of context" x))
...))
...
(define-for-syntax the-list
(apply append
(list
(let* ([x (list (list #'kw ''kw) ...)]
[f (caar x)])
(map (lambda (x)
(define clause-name (car x))
(define clause-spec (cadr x))
(list clause-name f (coerce clause-spec)))
x))
...))))]))
#; (define-syntax (define-keywords stx)
(define-syntax-rule (syntax-parse stx #:literals (DEFAULT)
(define-keywords the-list (kw coerce) ...) [(_ the-list super-list define-create
(begin (kw:identifier
(provide kw ...) (~optional kw-alt:identifier
(define-syntax kw #:defaults ((kw-alt (datum->syntax stx (gensym)))))
(lambda (x) (~optional (~seq DEFAULT default:expr))
(raise-syntax-error 'kw "used out of context" x))) coerce:expr) ...)
... (let* ([defs (attribute default)])
(define-for-syntax the-list #`(begin
(list (list #'kw (coerce ''kw)) ...)))) ;; define and create list of keywords and associated values
(define-for-syntax the-list
(append super-list
(list
(list #'kw #'kw (coerce ''kw) default)
#;
(list #'kw-alt #'kw (coerce ''kw-alt) default))
...))
;; define and provide keywords
(provide (rename-out (kw kw-alt) ...))
(provide kw ...)
(define-syntaxes (kw ...)
(values (lambda (x)
(raise-syntax-error 'kw "used out of context" x))
...))
(define-syntax (define-create stx)
(syntax-case stx ()
[(_ para (... ...))
(let* [[kwds (map cadr the-list)]
[defs (map cadddr the-list)]
[args (lambda (para*)
(append
para*
(foldr (lambda (x d rst)
(define k (string->keyword
(symbol->string
(syntax-e x))))
;; This 'if' doesn't work because
;; I don't know how to use 'attribute'
;; properly here and have default values
;; for everything. big-bang and universe
;; check already that defaults are provided.
; (displayln x)
; (displayln d)
(if d
(append (list k `(,x ,d)) rst)
(append (list k x) rst)))
'()
kwds
defs)))]
[body (lambda (para*)
(map (lambda (x) `(,x ,x)) (append para* kwds)))]]
(let ([para* (syntax->list #'(para (... ...)))])
#`(lambda (%)
(lambda #,(args para*)
(lambda ()
(define o (new % #,@(body para*)))
o)))))]))))]))
#| #|
transform the clauses into the initial arguments specification transform the clauses into the initial arguments specification
@ -62,24 +91,26 @@
if anything fails, use the legal keyword to specialize the error message if anything fails, use the legal keyword to specialize the error message
|# |#
(define (->args tag stx state0 clauses AllSpec PartSpec ->rec? legal) (define (->args tag stx state0 clauses Spec ->rec? legal)
(define msg (format "not a legal clause in a ~a description" legal)) (define msg (format "not a legal clause in a ~a description" legal))
(define Spec (append AllSpec PartSpec))
(define kwds (map (compose (curry datum->syntax stx) car) Spec)) (define kwds (map (compose (curry datum->syntax stx) car) Spec))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds)) (define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
(duplicates? tag spec) (duplicates? tag spec)
(not-a-clause tag stx state0 kwds) (not-a-clause tag stx state0 kwds)
(map (lambda (x) (apply append
(define kw (car x)) (map (lambda (x)
(define-values (key coercion) (define kw (car x))
(let loop ([kwds kwds][Spec Spec]) (define-values (key coercion)
(if (free-identifier=? (car kwds) kw) (let loop ([kwds kwds][Spec Spec])
;; -- the original keyword, which is also the init-field name (if (free-identifier=? (car kwds) kw)
;; -- the coercion that comes with it ;; -- the original keyword, which is also the init-field name
(values (cadar Spec) (caddar Spec)) ;; -- the coercion that comes with it
(loop (cdr kwds) (cdr Spec))))) (values (cadar Spec) (caddar Spec))
(list (mk-kwd key) (coercion (cdr x)))) (loop (cdr kwds) (cdr Spec)))))
spec)) (list (mk-kwd key) (coercion (cdr x))))
spec)))
(define (tee x) (displayln 'tee) (displayln x) x)
;; Syntax -> Syntax ;; Syntax -> Syntax
;; eventually: convert syntax to keyword ;; eventually: convert syntax to keyword
@ -87,7 +118,7 @@
(define key:id (symbol->string (syntax-e key))) (define key:id (symbol->string (syntax-e key)))
(define key:wd (string->keyword key:id)) (define key:wd (string->keyword key:id))
; (displayln key:wd) ; (displayln key:wd)
key) key:wd)
;; Symbol Syntax Syntax [Listof Kw] -> true ;; Symbol Syntax Syntax [Listof Kw] -> true
;; effect: if state0 looks like a clause, raise special error ;; effect: if state0 looks like a clause, raise special error

31
collects/2htdp/private/timer.rkt
View File

@ -1,33 +1,32 @@
#lang scheme/gui #lang racket/gui
;; The module provides a timer mixing for world and universe. ;; The module provides a timer mixing for world and universe.
;; The interface ensures that super class provides start and stop method, ;; The interface ensures that super class provides start and stop method,
;; plus a call back for clock ticks. The super-init call provides the ;; BUT if fails to ensure that the class comes with a _tick_ field.
;; on-tick parameter, which the super-class uses to define the callback. ;; plus a call back for clock ticks. The super-init call sets the
;; tick field, which the super-class uses to define the callback.
(require "check-aux.ss") (require "check-aux.ss")
(provide clock-mixin start-stop<%>) (provide clock-mixin start-stop<%>)
(define start-stop<%> (interface () start! ptock stop!)) (define start-stop<%> (interface () start! ptock pptock stop!))
;; T = (U (World -> World) (list (World -> World) Nat))
;; X [(list (World -> World) Nat) -> X] [(World -> World) -> X] -> [T -> X]
(define (selector default lchoice pchoice)
(lambda (on-tick)
(cond
[(cons? on-tick) (lchoice on-tick)]
[(procedure? on-tick) (pchoice on-tick)]
[else default])))
(define clock-mixin (define clock-mixin
(mixin (start-stop<%>) () (mixin (start-stop<%>) ()
(inherit ptock) (inherit ptock)
(init-field [on-tick #f]) (init-field [on-tick #f])
(field [rate ((selector 0 second (lambda _ RATE)) on-tick)] (field [rate 0]
[tick void]
[timer (new timer% [notify-callback (lambda () (ptock))])]) [timer (new timer% [notify-callback (lambda () (ptock))])])
(cond
[(cons? on-tick) (set! rate (second on-tick))
(set! tick (first on-tick))]
[(procedure? on-tick) (set! rate RATE)
(set! tick on-tick)]
[else (void)])
(define/override (start!) (define/override (start!)
(unless (<= rate 0) (unless (<= rate 0)
(send timer start (number->integer (* 1000 rate) 'big-bang/universe 'clock-rate))) (send timer start (number->integer (* 1000 rate) 'big-bang/universe 'clock-rate)))
@ -35,4 +34,6 @@
(define/override (stop! w) (define/override (stop! w)
(send timer stop) (send timer stop)
(super stop! w)) (super stop! w))
(super-new [tick ((selector void first (lambda (x) x)) on-tick)]))) (define/override (pptock w)
(tick w))
(super-new)))

14
collects/2htdp/private/universe.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/gui #lang racket/gui
(require (for-syntax "syn-aux.ss") (require (for-syntax "syn-aux.ss")
"checked-cell.ss" "checked-cell.ss"
@ -30,14 +30,16 @@
(define universe% (define universe%
(last-mixin (last-mixin
(clock-mixin (clock-mixin
(class* object% (start-stop<%>) (inspect #f) (super-new) (class* object% (start-stop<%>)
(inspect #f)
(super-new)
(init-field ;; type Result (init-field ;; type Result
; = (make-bundle [Listof World] Universe [Listof Mail]) ; = (make-bundle [Listof World] Universe [Listof Mail])
universe0 ;; the initial state of the universe universe0 ;; the initial state of the universe
on-new ;; Universe World -> Result on-new ;; Universe World -> Result
on-msg ;; Universe World Message -> Result on-msg ;; Universe World Message -> Result
tick ;; Universe -> Result ;; tick ;; Universe -> Result
(state #f) ;; Boolean (state #f) ;; Boolean
(on-disconnect ;; Universe World -> Result (on-disconnect ;; Universe World -> Result
(lambda (u w) (make-bundle u '() '()))) (lambda (u w) (make-bundle u '() '())))
(to-string #f) ;; Universe -> String (to-string #f) ;; Universe -> String
@ -98,7 +100,9 @@
(def/cback private (pdisconnect iworld) on-disconnect (def/cback private (pdisconnect iworld) on-disconnect
(kill iworld)) (kill iworld))
(def/cback public (ptock) tick) ;; tick, tock : deal with a tick event for this world
(def/cback pubment (ptock) (lambda (w) (pptock w)))
(define/public (pptock w) (void))
;; IWorld -> Void ;; IWorld -> Void
;; effect: remove from given iworld from iworlds ;; effect: remove from given iworld from iworlds

137
collects/2htdp/private/world.rkt
View File

@ -6,7 +6,8 @@
"checked-cell.ss" "checked-cell.ss"
"stop.ss" "stop.ss"
"universe-image.ss" "universe-image.ss"
"utilities.rkt" ; "utilities.rkt"
"keywords.rkt"
htdp/error htdp/error
mzlib/runtime-path mzlib/runtime-path
mrlib/bitmap-label mrlib/bitmap-label
@ -58,7 +59,7 @@
(state #f) ;; Boolean (state #f) ;; Boolean
(register #f) ;; (U #f IP) (register #f) ;; (U #f IP)
(check-with True) ;; Any -> Boolean (check-with True) ;; Any -> Boolean
(tick K)) ;; (U (World -> World) (list (World -> World) Nat)) )
(init (init
(on-key K) ;; World KeyEvent -> World (on-key K) ;; World KeyEvent -> World
@ -227,74 +228,77 @@
(define draw# 0) (define draw# 0)
(set-draw#!) (set-draw#!)
(define-syntax-rule (def/pub-cback (name arg ...) transform) (define-syntax-rule
(def/cback pub (name arg ...) transform)
;; Any ... -> Boolean ;; Any ... -> Boolean
(define/public (name arg ...) (begin
(queue-callback (define/public (name arg ...)
(lambda () (queue-callback
(with-handlers ([exn? (handler #t)]) (lambda ()
(define tag (format "~a callback" 'transform)) (with-handlers ([exn? (handler #t)])
(define nw (transform (send world get) arg ...)) (define tag (format "~a callback" 'transform))
(define (d) (pdraw) (set-draw#!)) (define nw (transform (send world get) arg ...))
;; --- (define (d) (pdraw) (set-draw#!))
;; [Listof (Box [d | void])] ;; ---
(define w '()) ;; [Listof (Box [d | void])]
;; set all to void, then w to null (define w '())
;; when a high priority draw is scheduledd ;; set all to void, then w to null
;; --- ;; when a high priority draw is scheduledd
(when (package? nw) ;; ---
(broadcast (package-message nw)) (when (package? nw)
(set! nw (package-world nw))) (broadcast (package-message nw))
(if (stop-the-world? nw) (set! nw (package-world nw)))
(begin (if (stop-the-world? nw)
(set! nw (stop-the-world-world nw)) (begin
(send world set tag nw) (set! nw (stop-the-world-world nw))
(when last-picture (send world set tag nw)
(set! draw last-picture))
(when draw (pdraw))
(callback-stop! 'name)
(enable-images-button))
(let ([changed-world? (send world set tag nw)])
;; this is the old "Robby optimization" see checked-cell:
; unless changed-world?
(when draw
(cond
[(not drawing)
(set! drawing #t)
(let ([b (box d)])
(set! w (cons b w))
;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0)
(set-draw#!)
(for-each (lambda (b) (set-box! b void)) w)
(set! w '())
;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)]
[else
(set! draw# (- draw# 1))]))
(when (pstop)
(when last-picture (when last-picture
(set! draw last-picture) (set! draw last-picture))
(pdraw)) (when draw (pdraw))
(callback-stop! 'name) (callback-stop! 'name)
(enable-images-button)) (enable-images-button))
changed-world?))))))) (let ([changed-world? (send world set tag nw)])
;; this is the old "Robby optimization" see checked-cell:
; unless changed-world?
(when draw
(cond
[(not drawing)
(set! drawing #t)
(let ([b (box d)])
(set! w (cons b w))
;; low priority, otherwise it's too fast
(queue-callback (lambda () ((unbox b))) #f))]
[(< draw# 0)
(set-draw#!)
(for-each (lambda (b) (set-box! b void)) w)
(set! w '())
;; high!! the scheduled callback didn't fire
(queue-callback (lambda () (d)) #t)]
[else
(set! draw# (- draw# 1))]))
(when (pstop)
(when last-picture
(set! draw last-picture)
(pdraw))
(callback-stop! 'name)
(enable-images-button))
changed-world?))))))))
;; tick, tock : deal with a tick event for this world ;; tick, tock : deal with a tick event for this world
(def/pub-cback (ptock) tick) (def/cback pubment (ptock) (lambda (w) (pptock w)))
(define/public (pptock w) (void))
;; key events ;; key events
(def/pub-cback (pkey ke) key) (def/cback pubment (pkey ke) key)
;; release events ;; release events
(def/pub-cback (prelease ke) release) (def/cback pubment (prelease ke) release)
;; mouse events ;; mouse events
(def/pub-cback (pmouse x y me) mouse) (def/cback pubment (pmouse x y me) mouse)
;; receive revents ;; receive revents
(def/pub-cback (prec msg) rec) (def/cback pubment (prec msg) rec)
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; -> Void ;; -> Void
@ -348,6 +352,8 @@
[(stop-the-world? w) [(stop-the-world? w)
(stop! (stop-the-world-world (send world get)))])))))) (stop! (stop-the-world-world (send world get)))]))))))
; (define make-new-world (new-world world%))
;; ----------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------
(define-runtime-path break-btn:path '(lib "icons/break.png")) (define-runtime-path break-btn:path '(lib "icons/break.png"))
(define break-button:label (define break-button:label
@ -391,15 +397,18 @@
(set! event-history (cons (cons type stuff) event-history))) (set! event-history (cons (cons type stuff) event-history)))
;; --- new callbacks --- ;; --- new callbacks ---
(define-syntax-rule (def/over-cb (pname name arg ...)) (define-syntax-rule
(define/override (pname arg ...) (def/cb ovr (pname name arg ...))
(when (super pname arg ...) (add-event name arg ...)))) (begin
; (ovr pname)
(define/override (pname arg ...)
(when (super pname arg ...) (add-event 'name arg ...)))))
(def/over-cb (ptock tick)) (def/cb augment (ptock tick))
(def/over-cb (pkey key e)) (def/cb augment (pkey key e))
(def/over-cb (prelease release e)) (def/cb augment (prelease release e))
(def/over-cb (pmouse mouse x y me)) (def/cb augment (pmouse mouse x y me))
(def/over-cb (prec rec m)) (def/cb augment (prec rec m))
;; --> Void ;; --> Void
;; re-play the history of events; create a png per step; create animated gif ;; re-play the history of events; create a png per step; create animated gif

54
collects/2htdp/universe.rkt
View File

@ -134,13 +134,15 @@
[(V) (set! rec? #'V)] [(V) (set! rec? #'V)]
[_ (err '#'record? stx)])))] [_ (err '#'record? stx)])))]
[args [args
(->args 'big-bang stx (syntax w) (syntax (clause ...)) AllSpec WldSpec ->rec? "world")]) (->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec? "world")])
#`(let* ([esp (make-eventspace)] #`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args)))]))
[thd (eventspace-handler-thread esp)])
(with-handlers ((exn:break? (lambda (x) (break-thread thd)))) (require (only-in 2htdp/image circle))
(parameterize ([current-eventspace esp]) (define (main)
(let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)]) (big-bang 10
(send o last))))))])) (on-tick sub1)
(stop-when zero?)
(to-draw (lambda (x) (circle (+ 30 x) 'solid 'red)))))
(define (run-simulation f) (define (run-simulation f)
(check-proc 'run-simulation f 1 "first" "one argument") (check-proc 'run-simulation f 1 "first" "one argument")
@ -215,23 +217,45 @@
) )
(define-syntax (universe stx) (define-syntax (universe stx)
(define legal "not a legal clause in a universe description")
(syntax-case stx () (syntax-case stx ()
[(universe) (raise-syntax-error #f "not a legal universe description" stx)] [(universe) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)] [(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...) [(universe u bind ...)
(let* (let*
([args (->args 'universe stx (syntax u) (syntax (bind ...)) AllSpec UniSpec void "universe")] ([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
[domain (map (compose syntax-e car) args)]) [domain (map (lambda (x)
(if (keyword? x)
(string->symbol (keyword->string x))
x))
args)])
(cond (cond
[(not (memq 'on-new domain)) [(not (memq 'on-new domain))
(raise-syntax-error #f "missing on-new clause" stx)] (raise-syntax-error #f "missing on-new clause" stx)]
[(not (memq 'on-msg domain)) [(not (memq 'on-msg domain))
(raise-syntax-error #f "missing on-msg clause" stx)] (raise-syntax-error #f "missing on-msg clause" stx)]
[else ; (and (memq #'on-new domain) (memq #'on-msg domain)) [else ; (and (memq #'on-new domain) (memq #'on-msg domain))
#`(let* ([esp (make-eventspace)] #`(run-it ((new-universe universe%) u #,@args))]))]))
[thd (eventspace-handler-thread esp)])
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
(parameterize ([current-eventspace esp])
(send (new universe% [universe0 u] #,@args) last))))]))]))
;
;
;
; ; ;;;
; ;
; ;;; ;; ;; ;;;;;; ;; ;;; ;;;;
; ; ;; ; ; ;; ; ;
; ; ; ; ; ; ;;;;;
; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;;
; ;;;;; ;;; ;;; ;;;;;; ;;;;; ;;; ;;
;
;
;
;
;; (-> Object) -> Any
(define (run-it o)
(define esp (make-eventspace))
(define thd (eventspace-handler-thread esp))
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
(parameterize ([current-eventspace esp])
(send (o) last))))