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

svn: r15616

Browse Source
This commit is contained in:
Matthias Felleisen 2009-07-29 02:21:32 +00:00
parent 84485e14ad
commit 6dcc67cb25
1 changed files with 27 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/2htdp/universe.ss
View File

@ -14,6 +14,7 @@
"private/launch-many-worlds.ss" "private/launch-many-worlds.ss"
htdp/error htdp/error
(rename-in lang/prim (first-order->higher-order f2h)) (rename-in lang/prim (first-order->higher-order f2h))
(for-syntax (rename-in lang/prim (first-order->higher-order f2h)))
(only-in mzlib/etc evcase)) (only-in mzlib/etc evcase))
(provide (all-from-out "private/image.ss")) (provide (all-from-out "private/image.ss"))
@ -142,12 +143,15 @@
(define-syntax (big-bang stx) (define-syntax (big-bang stx)
(syntax-case stx () (syntax-case stx ()
[(big-bang) (raise-syntax-error #f "bad world description" stx)] [(big-bang)
(raise-syntax-error #f "big-bang needs at least an initial world;" stx)]
[(big-bang w s ...) [(big-bang w s ...)
(let* ([Spec (append AllSpec WldSpec)] (let* (;; [Listof (list Keyword Contract)]
[Spec (append AllSpec WldSpec)]
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))] [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
[rec? #'#f] [rec? #'#f]
[spec (map (lambda (stx) ;; [Listof (cons Keyword Value)]
[wrld (map (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(kw . E) [(kw . E)
(and (identifier? #'kw) (and (identifier? #'kw)
@ -157,19 +161,24 @@
(syntax-case #'E () (syntax-case #'E ()
[(V) (set! rec? #'V)] [(V) (set! rec? #'V)]
[_ (err 'record? stx)])) [_ (err 'record? stx)]))
(cons #'kw #;(syntax-e #'kw) (syntax E)))] (cons #'kw #'E #;(syntax E)))]
[_ (raise-syntax-error [_ (raise-syntax-error
'big-bang "not a legal big-bang clause" stx)])) 'big-bang "not a legal big-bang clause" stx)]))
(syntax->list (syntax (s ...))))] (syntax->list (syntax (s ...))))]
;; assert: all bind = (kw . E) and kw is constrained via Bind ;; assert: all items of wrld have shape (kw . E)
;; and all kw are guaranted in the domain of Spec
;; now bring together the coercion-contracts and the values,
;; PLUS use the 'local' version of the keyword because it is
;; also the name of the class
[args (map (lambda (x) [args (map (lambda (x)
(define kw (car x)) (define kw (car x))
(define co ;; patch from Jay to allow rename on import (define-values (key coercion)
(findf (lambda (n) (free-identifier=? kw (car n))) (let loop ([kwds kwds][Spec Spec])
(map (lambda (k s) (cons k (cdr s))) (if (free-identifier=? (car kwds) kw)
kwds Spec))) (values (car kwds) (cadar Spec))
(list (syntax-e (car co)) ((cadr co) (cdr x)))) (loop (cdr kwds) (cdr Spec)))))
spec)]) (list key (coercion (cdr x))))
wrld)])
#`(parameterize ([current-eventspace (make-eventspace)]) #`(parameterize ([current-eventspace (make-eventspace)])
(let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)]) (let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)])
(send o last))))])) (send o last))))]))