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

#'record problem

Browse Source 
svn: r16309
This commit is contained in:
Matthias Felleisen 2009-10-13 18:30:02 +00:00
parent c24b05a7b0
commit f218661bde
1 changed files with 9 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/2htdp/universe.ss
View File

@ -152,7 +152,7 @@
;; -- 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? (expr-with-check bool> "expected a boolean (to record? or not)")]
[name (expr-with-check string> "expected a name (string) for the world")] [name (expr-with-check string> "expected a name (string) for the world")]
;; -- register must specify the internet address of a host (including LOCALHOST) ;; -- register must specify the internet address of a host (e.g., LOCALHOST)
[register (expr-with-check ip> "expected a host (ip address)")]) [register (expr-with-check ip> "expected a host (ip address)")])
(define-syntax (big-bang stx) (define-syntax (big-bang stx)
@ -162,12 +162,13 @@
[(big-bang w clause ...) [(big-bang w clause ...)
(let* ([rec? #'#f] (let* ([rec? #'#f]
[->rec? [->rec?
(lambda (kw) (lambda (kw E)
(when (free-identifier=? kw #'record?) (when (free-identifier=? kw #'record?)
(syntax-case #'E () (syntax-case E ()
[(V) (set! rec? #'V)] [(V) (set! rec? #'V)]
[_ (err 'record? stx)])))] [_ (err '#'record? stx)])))]
[args (->args stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")]) [args
(->args stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
#`(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))))]))
@ -257,8 +258,9 @@
[(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* ([args (->args stx (syntax (bind ...)) AllSpec UniSpec void "universe")] (let*
[domain (map (compose syntax-e car) args)]) ([args (->args stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
[domain (map (compose syntax-e car) 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)]