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

fix mismatch between identifier and datums in module paths; revive HtDP language tests; fix quick's cache

Browse Source 
svn: r7833
This commit is contained in:
Matthew Flatt 2007-11-26 00:38:58 +00:00
parent 5f312dcbde
commit 2c6a894474
10 changed files with 211 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/scheme/private/reqprov.ss
View File

@ -28,8 +28,27 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lib ;; lib
(define-for-syntax (xlate-path stx)
(if (pair? (syntax-e stx))
(let ([kw
;; free-identifier=? identifers are not necessarily module=?
(syntax-case stx (lib planet file quote)
[(quote . _) 'quote]
[(lib . _) 'lib]
[(planet . _) 'planet]
[(file . _) 'file])]
[d (syntax->datum stx)])
(if (eq? (car d) kw)
stx
(datum->syntax
stx
(cons kw (cdr d))
stx
stx)))
stx))
(define-for-syntax (check-lib-form stx) (define-for-syntax (check-lib-form stx)
(unless (module-path? (syntax->datum stx)) (unless (module-path? (syntax->datum (xlate-path stx)))
(raise-syntax-error (raise-syntax-error
#f #f
"ill-formed module path" "ill-formed module path"
@ -163,16 +182,18 @@
[(eq? mode 'label) #`(for-label #,base)] [(eq? mode 'label) #`(for-label #,base)]
[else (error "huh?" mode)]))] [else (error "huh?" mode)]))]
[simple-path? (lambda (p) [simple-path? (lambda (p)
(syntax-case p (lib) (syntax-case p (lib quote)
[(lib . _) [(lib . _)
(check-lib-form p)] (check-lib-form p)]
[(quote . _)
(check-lib-form p)]
[_ [_
(or (identifier? p) (or (identifier? p)
(and (string? (syntax-e p)) (and (string? (syntax-e p))
(module-path? (syntax-e p))))]))] (module-path? (syntax-e p))))]))]
[transform-simple [transform-simple
(lambda (in base-mode) (lambda (in base-mode)
(syntax-case in (lib file planet prefix-in except-in) (syntax-case in (lib file planet prefix-in except-in quote)
;; Detect simple cases first: ;; Detect simple cases first:
[_ [_
(string? (syntax-e in)) (string? (syntax-e in))
@ -185,17 +206,21 @@
in)) in))
(list (mode-wrap base-mode in)))] (list (mode-wrap base-mode in)))]
[_ [_
(identifier? in) (and (identifier? in)
(module-path? (syntax-e #'in)))
(list (mode-wrap base-mode in))] (list (mode-wrap base-mode in))]
[(quote . s)
(check-lib-form in)
(list (mode-wrap base-mode (xlate-path in)))]
[(lib . s) [(lib . s)
(check-lib-form in) (check-lib-form in)
(list (mode-wrap base-mode in))] (list (mode-wrap base-mode (xlate-path in)))]
[(file . s) [(file . s)
(check-lib-form in) (check-lib-form in)
(list (mode-wrap base-mode in))] (list (mode-wrap base-mode (xlate-path in)))]
[(planet . s) [(planet . s)
(check-lib-form in) (check-lib-form in)
(list (mode-wrap base-mode in))] (list (mode-wrap base-mode (xlate-path in)))]
[(prefix-in pfx path) [(prefix-in pfx path)
(simple-path? #'path) (simple-path? #'path)
(list (mode-wrap (list (mode-wrap
@ -204,7 +229,7 @@
#'path #'path
(syntax-e (syntax-e
(quasisyntax (quasisyntax
(prefix pfx path))) (prefix pfx #,(xlate-path #'path))))
in in
in)))] in)))]
[(except-in path id ...) [(except-in path id ...)
@ -218,7 +243,7 @@
#'path #'path
(syntax-e (syntax-e
(quasisyntax/loc in (quasisyntax/loc in
(all-except path id ...))))))] (all-except #,(xlate-path #'path) id ...))))))]
;; General case: ;; General case:
[_ (let-values ([(imports sources) (expand-import in)]) [_ (let-values ([(imports sources) (expand-import in)])
;; TODO: collapse back to simple cases when possible ;; TODO: collapse back to simple cases when possible

48
collects/scheme/require-transform.ss
View File

@ -60,26 +60,34 @@
(syntax-case stx (quote) (syntax-case stx (quote)
[(quote s) #t] [(quote s) #t]
[_ #f])) [_ #f]))
;; FIXME: check format of string (let ([mod-path
(let-values ([(names et-names lt-names) (syntax-local-module-exports stx)]) (if (pair? (syntax-e #'simple))
(values `(quote . ,(cdr (syntax->datum #'simple)))
(apply (syntax->datum #'simple))])
append (unless (module-path? mod-path)
(map (lambda (names mode) (raise-syntax-error
(map (lambda (name) #f
(make-import (datum->syntax "invalid module-path form"
stx stx))
name (let-values ([(names et-names lt-names) (syntax-local-module-exports stx)])
stx) (values
name (apply
(syntax->datum #'simple) append
mode (map (lambda (names mode)
'run (map (lambda (name)
stx)) (make-import (datum->syntax
names)) stx
(list names et-names lt-names) name
(list 'run 'syntax 'label))) stx)
(list (make-import-source #'simple 'run))))] name
mod-path
mode
'run
stx))
names))
(list names et-names lt-names)
(list 'run 'syntax 'label)))
(list (make-import-source #'simple 'run)))))]
[(id . rest) [(id . rest)
(identifier? #'id) (identifier? #'id)
(let ([t (syntax-local-value #'id (lambda () #f))]) (let ([t (syntax-local-value #'id (lambda () #f))])

204
collects/scribblings/quick/images/exprs.dat
View File

@ -1,102 +1,102 @@
(0 () 0 () () 5) ((1) 0 () 0 () () 5)
(0 () 0 () () 5) ((1) 0 () 0 () () 5)
(0 () 0 () () "art gallery") ((1) 0 () 0 () () "art gallery")
(0 () 0 () () "art gallery") ((1) 0 () 0 () () "art gallery")
(0 () 0 () () (c! circle c! 10)) ((1) 0 () 0 () () (c circle c 10))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img0.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img0.png")) (c "[image]")))))
(0 () 0 () () (c! rectangle c! 10 c! 20)) ((1) 0 () 0 () () (c rectangle c 10 c 20))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img1.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img1.png")) (c "[image]")))))
(0 () 0 () () (c! circle c! 10 c! 20)) ((1) 0 () 0 () () (c circle c 10 c 20))
(1 (((lib "quick/exn.ss" "scribblings") . deserialize-info:mr-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20")) ((1) 1 (((lib "exn.ss" "scribblings" "quick") . deserialize-info:mr-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20"))
(0 () 0 () () (c! hc-append c! (c! circle c! 10) c! (c! rectangle c! 10 c! 20))) ((1) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img2.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img2.png")) (c "[image]")))))
(0 () 0 () () (c! define c! c c! (c! circle c! 10))) ((1) 0 () 0 () () (c define c c c (c circle c 10)))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! define c! r c! (c! rectangle c! 10 c! 20))) ((1) 0 () 0 () () (c define c r c (c rectangle c 10 c 20)))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () r) ((1) 0 () 0 () () r)
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img3.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img3.png")) (c "[image]")))))
(0 () 0 () () (c! hc-append c! c c! r)) ((1) 0 () 0 () () (c hc-append c c c r))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img4.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img4.png")) (c "[image]")))))
(0 () 0 () () (c! hc-append c! 20 c! c c! r c! c)) ((1) 0 () 0 () () (c hc-append c 20 c c c r c c))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img5.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img5.png")) (c "[image]")))))
(0 () 0 () () (c! define c! (c! square c! n) c! (c! filled-rectangle c! n c! n))) ((1) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n)))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! square c! 10)) ((1) 0 () 0 () () (c square c 10))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img6.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img6.png")) (c "[image]")))))
(0 () 0 () () (c! define c! (c! four c! p) c! (c! define c! two-p c! (c! hc-append c! p c! p)) c! (c! vc-append c! two-p c! two-p))) ((1) 0 () 0 () () (c define c (c four c p) c (c define c two-p c (c hc-append c p c p)) c (c vc-append c two-p c two-p)))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! four c! (c! circle c! 10))) ((1) 0 () 0 () () (c four c (c circle c 10)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img7.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img7.png")) (c "[image]")))))
(0 () 0 () () (c! define c! (c! checker c! p1 c! p2) c! (c! let c! (c! (c! p12 c! (c! hc-append c! p1 c! p2)) c! (c! p21 c! (c! hc-append c! p2 c! p1))) c! (c! vc-append c! p12 c! p21)))) ((1) 0 () 0 () () (c define c (c checker c p1 c p2) c (c let c (c (c p12 c (c hc-append c p1 c p2)) c (c p21 c (c hc-append c p2 c p1))) c (c vc-append c p12 c p21))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! checker c! (c! colorize c! (c! square c! 10) c! "red") c! (c! colorize c! (c! square c! 10) c! "black"))) ((1) 0 () 0 () () (c checker c (c colorize c (c square c 10) c "red") c (c colorize c (c square c 10) c "black")))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img8.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img8.png")) (c "[image]")))))
(0 () 0 () () (c! define c! (c! checkerboard c! p) c! (c! let* c! (c! (c! rp c! (c! colorize c! p c! "red")) c! (c! bp c! (c! colorize c! p c! "black")) c! (c! c c! (c! checker c! rp c! bp)) c! (c! c4 c! (c! four c! c))) c! (c! four c! c4)))) ((1) 0 () 0 () () (c define c (c checkerboard c p) c (c let* c (c (c rp c (c colorize c p c "red")) c (c bp c (c colorize c p c "black")) c (c c c (c checker c rp c bp)) c (c c4 c (c four c c))) c (c four c c4))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! checkerboard c! (c! square c! 10))) ((1) 0 () 0 () () (c checkerboard c (c square c 10)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img9.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img9.png")) (c "[image]")))))
(0 () 0 () () circle) ((1) 0 () 0 () () circle)
(1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c! (u . "#<procedure:circle>")))) ((1) 1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#<procedure:circle>"))))
(0 () 0 () () (c! define c! (c! series c! mk) c! (c! hc-append c! 4 c! (c! mk c! 5) c! (c! mk c! 10) c! (c! mk c! 20)))) ((1) 0 () 0 () () (c define c (c series c mk) c (c hc-append c 4 c (c mk c 5) c (c mk c 10) c (c mk c 20))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! series c! circle)) ((1) 0 () 0 () () (c series c circle))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img10.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img10.png")) (c "[image]")))))
(0 () 0 () () (c! series c! square)) ((1) 0 () 0 () () (c series c square))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img11.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img11.png")) (c "[image]")))))
(0 () 0 () () (c! series c! (c! lambda c! (c! size) c! (c! checkerboard c! (c! square c! size))))) ((1) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size)))))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img12.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img12.png")) (c "[image]")))))
(0 () 0 () () (c! define c! (c! rgb-series c! mk) c! (c! vc-append c! (c! series c! (c! lambda c! (c! sz) c! (c! colorize c! (c! mk c! sz) c! "red"))) c! (c! series c! (c! lambda c! (c! sz) c! (c! colorize c! (c! mk c! sz) c! "green"))) c! (c! series c! (c! lambda c! (c! sz) c! (c! colorize c! (c! mk c! sz) c! "blue")))))) ((1) 0 () 0 () () (c define c (c rgb-series c mk) c (c vc-append c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "red"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "green"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "blue"))))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! rgb-series c! circle)) ((1) 0 () 0 () () (c rgb-series c circle))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img13.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img13.png")) (c "[image]")))))
(0 () 0 () () (c! rgb-series c! square)) ((1) 0 () 0 () () (c rgb-series c square))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img14.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img14.png")) (c "[image]")))))
(0 () 0 () () (c! define c! (c! rgb-maker c! mk) c! (c! lambda c! (c! sz) c! (c! vc-append c! (c! colorize c! (c! mk c! sz) c! "red") c! (c! colorize c! (c! mk c! sz) c! "green") c! (c! colorize c! (c! mk c! sz) c! "blue"))))) ((1) 0 () 0 () () (c define c (c rgb-maker c mk) c (c lambda c (c sz) c (c vc-append c (c colorize c (c mk c sz) c "red") c (c colorize c (c mk c sz) c "green") c (c colorize c (c mk c sz) c "blue")))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! series c! (c! rgb-maker c! circle))) ((1) 0 () 0 () () (c series c (c rgb-maker c circle)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img15.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img15.png")) (c "[image]")))))
(0 () 0 () () (c! series c! (c! rgb-maker c! square))) ((1) 0 () 0 () () (c series c (c rgb-maker c square)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img16.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img16.png")) (c "[image]")))))
(0 () 0 () () (c! list c! "red" c! "green" c! "blue")) ((1) 0 () 0 () () (c list c "red" c "green" c "blue"))
(0 () 0 () () (c! "red" c! "green" c! "blue")) ((1) 0 () 0 () () (c "red" c "green" c "blue"))
(0 () 0 () () (c! list c! (c! circle c! 10) c! (c! square c! 10))) ((1) 0 () 0 () () (c list c (c circle c 10) c (c square c 10)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 1 ("[image]") () (c! (0 #f (c! (0 (1 (u . "images/img17.png")) (c! (? . 0))))) c! (0 #f (c! (0 (1 (u . "images/img18.png")) (c! (? . 0))))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 1 ("[image]") () (c (0 #f (c (0 (1 (u . "images/img17.png")) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img18.png")) (c (? . 0)))))))
(0 () 0 () () (c! define c! (c! rainbow c! p) c! (c! map c! (c! lambda c! (c! color) c! (c! colorize c! p c! color)) c! (c! list c! "red" c! "orange" c! "yellow" c! "green" c! "blue" c! "purple")))) ((1) 0 () 0 () () (c define c (c rainbow c p) c (c map c (c lambda c (c color) c (c colorize c p c color)) c (c list c "red" c "orange" c "yellow" c "green" c "blue" c "purple"))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! rainbow c! (c! square c! 5))) ((1) 0 () 0 () () (c rainbow c (c square c 5)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 1 ("[image]") () (c! (0 #f (c! (0 (1 (u . "images/img19.png")) (c! (? . 0))))) c! (0 #f (c! (0 (1 (u . "images/img20.png")) (c! (? . 0))))) c! (0 #f (c! (0 (1 (u . "images/img21.png")) (c! (? . 0))))) c! (0 #f (c! (0 (1 (u . "images/img22.png")) (c! (? . 0))))) c! (0 #f (c! (0 (1 (u . "images/img23.png")) (c! (? . 0))))) c! (0 #f (c! (0 (1 (u . "images/img24.png")) (c! (? . 0))))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 1 ("[image]") () (c (0 #f (c (0 (1 (u . "images/img19.png")) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img20.png")) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img21.png")) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img22.png")) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img23.png")) (c (? . 0))))) c (0 #f (c (0 (1 (u . "images/img24.png")) (c (? . 0)))))))
(0 () 0 () () (c! apply c! vc-append c! (c! rainbow c! (c! square c! 5)))) ((1) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5))))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img25.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img25.png")) (c "[image]")))))
(0 () 0 () () (c! require c! (c! lib c! "flash.ss" c! "texpict"))) ((1) 0 () 0 () () (c require c texpict/flash))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! filled-flash c! 40 c! 30)) ((1) 0 () 0 () () (c filled-flash c 40 c 30))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img26.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img26.png")) (c "[image]")))))
(0 () 0 () () (c! require c! (c! planet c! "random.ss" c! (c! "schematics" c! "random.plt" c! 1 c! 0)))) ((1) 0 () 0 () () (c require c (c planet c "random.ss" c (c "schematics" c "random.plt" c 1 c 0))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! random-gaussian)) ((1) 0 () 0 () () (c random-gaussian))
(0 () 0 () () 0.9050686838895684) ((1) 0 () 0 () () 0.9050686838895684)
(0 () 0 () () (c! require c! (c! lib c! "code.ss" c! "slideshow"))) ((1) 0 () 0 () () (c require c (c lib c "code.ss" c "slideshow")))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! code c! (c! circle c! 10))) ((1) 0 () 0 () () (c code c (c circle c 10)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img27.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img27.png")) (c "[image]")))))
(0 () 0 () () (c! define-syntax c! pict+code c! (c! syntax-rules c! () c! (c! (c! pict+code c! expr) c! (c! hc-append c! 10 c! expr c! (c! code c! expr)))))) ((1) 0 () 0 () () (c define-syntax c pict+code c (c syntax-rules c () c (c (c pict+code c expr) c (c hc-append c 10 c expr c (c code c expr))))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! pict+code c! (c! circle c! 10))) ((1) 0 () 0 () () (c pict+code c (c circle c 10)))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img28.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img28.png")) (c "[image]")))))
(0 () 0 () () (c! require c! (c! lib c! "class.ss" c! "mzlib") c! (c! lib c! "mred.ss" c! "mred"))) ((1) 0 () 0 () () (c require c (c lib c "class.ss" c "mzlib") c (c lib c "mred.ss" c "mred")))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! define c! f c! (c! new c! frame% c! (c! label c! "My Art") c! (c! width c! 300) c! (c! height c! 300) c! (c! alignment c! (c! quote c! (c! center c! center)))))) ((1) 0 () 0 () () (c define c f c (c new c frame% c (c label c "My Art") c (c width c 300) c (c height c 300) c (c alignment c (c quote c (c center c center))))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! send c! f c! show c! #t)) ((1) 0 () 0 () () (c send c f c show c #t))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! send c! f c! show c! #f)) ((1) 0 () 0 () () (c send c f c show c #f))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! define c! (c! add-drawing c! p) c! (c! let c! (c! (c! drawer c! (c! make-pict-drawer c! p))) c! (c! new c! canvas% c! (c! parent c! f) c! (c! style c! (c! quote c! (c! border))) c! (c! paint-callback c! (c! lambda c! (c! self c! dc) c! (c! drawer c! dc c! 0 c! 0))))))) ((1) 0 () 0 () () (c define c (c add-drawing c p) c (c let c (c (c drawer c (c make-pict-drawer c p))) c (c new c canvas% c (c parent c f) c (c style c (c quote c (c border))) c (c paint-callback c (c lambda c (c self c dc) c (c drawer c dc c 0 c 0)))))))
(0 () 0 () () (void)) ((1) 0 () 0 () () (void))
(0 () 0 () () (c! add-drawing c! (c! pict+code c! (c! circle c! 10)))) ((1) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10))))
(1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c! (u . "#2(struct:object:canvas% ...)")))) ((1) 1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
(0 () 0 () () (c! add-drawing c! (c! colorize c! (c! filled-flash c! 50 c! 30) c! "yellow"))) ((1) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow")))
(1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c! (u . "#2(struct:object:canvas% ...)")))) ((1) 1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
(0 () 0 () () (c! scale c! (c! bitmap c! "art.png") c! 0.5)) ((1) 0 () 0 () () (c scale c (c bitmap c "art.png") c 0.5))
(2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c! (0 (1 (u . "images/img29.png")) (c! "[image]"))))) ((1) 2 (((lib "struct.ss" "scribble") . deserialize-info:element-v0) ((lib "struct.ss" "scribble") . deserialize-info:image-file-v0)) 0 () () (0 #f (c (0 (1 (u . "images/img29.png")) (c "[image]")))))

2
collects/tests/mzscheme/advanced.ss
View File

@ -21,7 +21,7 @@
(cdr row))) (cdr row)))
docs)) docs))
(define current-htdp-lang '(lib "htdp-advanced.ss" "lang")) (define current-htdp-lang 'lang/htdp-advanced)
(load-relative "htdp-test.ss") (load-relative "htdp-test.ss")
(require (lib "htdp-advanced.ss" "lang")) (require (lib "htdp-advanced.ss" "lang"))

7
collects/tests/mzscheme/beginner-abbr.ss
View File

@ -15,10 +15,11 @@
;; Don't need these: ;; Don't need these:
(define no-extra-if-tests? #t) (define no-extra-if-tests? #t)
(require (rename mzscheme exn:fail? exn:fail?) (require (only-in mzscheme
(rename mzscheme exn:fail:contract? exn:fail:contract?)) exn:fail?
exn:fail:contract?))
(define current-htdp-lang '(lib "htdp-beginner-abbr.ss" "lang")) (define current-htdp-lang 'lang/htdp-beginner-abbr)
(load-relative "htdp-test.ss") (load-relative "htdp-test.ss")
(require (lib "htdp-beginner-abbr.ss" "lang")) (require (lib "htdp-beginner-abbr.ss" "lang"))

2
collects/tests/mzscheme/beginner.ss
View File

@ -81,7 +81,7 @@
(require (only-in mzscheme exn:fail? exn:fail:contract?)) (require (only-in mzscheme exn:fail? exn:fail:contract?))
(define current-htdp-lang '(lib "htdp-beginner.ss" "lang")) (define current-htdp-lang 'lang/htdp-beginner)
(load-relative "htdp-test.ss") (load-relative "htdp-test.ss")
(require (lib "htdp-beginner.ss" "lang")) (require (lib "htdp-beginner.ss" "lang"))

61
collects/tests/mzscheme/htdp-test.ss
View File

@ -3,7 +3,7 @@
;; Just to be sure, remove all top-level context from the syntax object ;; Just to be sure, remove all top-level context from the syntax object
(cond (cond
[(syntax? v) [(syntax? v)
(datum->syntax-object (datum->syntax
#f #f
(strip-context (syntax-e v)) (strip-context (syntax-e v))
v v
@ -37,21 +37,23 @@
(cond (cond
[(null? teachpack-accum) lang] [(null? teachpack-accum) lang]
[(equal? teachpack-accum previous-tp-accum) [(equal? teachpack-accum previous-tp-accum)
previous-tp-lang] `',previous-tp-lang]
[else [else
(let ([name (string->symbol (format "~a+tp~a" lang (gensym)))]) (let ([name (string->symbol (format "~a+tp~a" lang (gensym)))])
(eval #`(module #,name mzscheme (eval #`(module #,name mzscheme
(define-syntax (bounce stx) (define-syntax (bounce stx)
#'(begin #'(begin
(require #,lang #,@teachpack-accum) (require #,lang #,@(map (lambda (t)
#`(quote #,t))
teachpack-accum))
(provide (all-from #,lang) (provide (all-from #,lang)
#,@(map (lambda (tp) #,@(map (lambda (tp)
#`(all-from #,tp)) #`(all-from (quote #,tp)))
teachpack-accum)))) teachpack-accum))))
(bounce))) (bounce)))
(set! previous-tp-accum teachpack-accum) (set! previous-tp-accum teachpack-accum)
(set! previous-tp-lang name) (set! previous-tp-lang name)
name)])) `',name)]))
(define htdp-syntax-test (define htdp-syntax-test
(case-lambda (case-lambda
@ -66,7 +68,8 @@
(require (only-in mzscheme (require (only-in mzscheme
[let mz-let] [let mz-let]
[require mz-require])) [require mz-require]
[quote mz-quote]))
(define-syntax (htdp-test stx) (define-syntax (htdp-test stx)
(syntax-case stx () (syntax-case stx ()
@ -85,9 +88,9 @@
#`(module #,name #,(add-teachpacks current-htdp-lang) #`(module #,name #,(add-teachpacks current-htdp-lang)
#,@body-accum #,@body-accum
#,(strip-context #'expr))) #,(strip-context #'expr)))
(dynamic-require name #f))] (dynamic-require `',name #f))]
[_ [_
(printf "~s\n" (syntax-object->datum stx)) (printf "~s\n" (syntax->datum stx))
#'(void)])) #'(void)]))
(define (htdp-string-to-pred exn?/rx) (define (htdp-string-to-pred exn?/rx)
@ -106,18 +109,26 @@
(define (htdp-error-test stx) (define (htdp-error-test stx)
(do-htdp-test stx #t #f)) (do-htdp-test stx #t #f))
(module helper mzscheme (module helper scheme/base
(require (for-syntax scheme/base))
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(syntax-case stx () (syntax-case stx ()
[(_ the-test lang to-export requires . rest) [(_ the-test lang mb to-export (tp ...) . rest)
#`(#%module-begin (with-syntax ([(tp ...)
(require (rename tester the-test test)) (map (lambda (tp)
(require lang . requires) (datum->syntax
#,@(if (syntax-object->datum (syntax to-export)) tp
(list (syntax (provide to-export))) (list #'quote tp)
'()) tp))
. rest)])) (syntax->list #'(tp ...)))])
(provide (rename module-begin #%module-begin))) #`(#%module-begin
(require (only-in 'tester [test the-test]))
(require (except-in lang mb) tp ...)
#,@(if (syntax->datum (syntax to-export))
(list (syntax (provide to-export)))
'())
. rest))]))
(provide (rename-out [module-begin #%module-begin])))
(module tester mzscheme (module tester mzscheme
(define test (namespace-variable-value 'test)) (define test (namespace-variable-value 'test))
@ -126,17 +137,17 @@
(define (do-htdp-test stx stx-err? exn?) (define (do-htdp-test stx stx-err? exn?)
(let ([name (gensym 'm)]) (let ([name (gensym 'm)])
((if stx-err? syntax-test eval) ((if stx-err? syntax-test eval)
#`(module #,name helper #`(module #,name 'helper
test test
(all-except #,current-htdp-lang #%module-begin) #,current-htdp-lang #%module-begin
#f #f
#,teachpack-accum #,teachpack-accum
#,@body-accum #,@body-accum
#,(strip-context stx))) #,(strip-context stx)))
(unless stx-err? (unless stx-err?
(if exn? (if exn?
(err/rt-test (eval #`(mz-require #,name)) exn?) (err/rt-test (eval #`(mz-require '#,name)) exn?)
(eval #`(mz-require #,name)))))) (eval #`(mz-require '#,name))))))
(define-syntax (htdp-eval stx) (define-syntax (htdp-eval stx)
(syntax-case stx () (syntax-case stx ()
@ -145,11 +156,11 @@
(define (do-htdp-eval stx) (define (do-htdp-eval stx)
(let ([name (gensym 'm)]) (let ([name (gensym 'm)])
(eval (eval
#`(module #,name helper #`(module #,name 'helper
test test
(all-except #,current-htdp-lang #%module-begin) #,current-htdp-lang #%module-begin
the-answer the-answer
#,teachpack-accum #,teachpack-accum
#,@body-accum #,@body-accum
(define the-answer #,(strip-context stx)))) (define the-answer #,(strip-context stx))))
(dynamic-require name 'the-answer))) (dynamic-require `',name 'the-answer)))

2
collects/tests/mzscheme/intermediate-lambda.ss
View File

@ -20,7 +20,7 @@
(cdr row))) (cdr row)))
docs)) docs))
(define current-htdp-lang '(lib "htdp-intermediate-lambda.ss" "lang")) (define current-htdp-lang 'lang/htdp-intermediate-lambda)
(load-relative "htdp-test.ss") (load-relative "htdp-test.ss")
(require (lib "htdp-intermediate-lambda.ss" "lang")) (require (lib "htdp-intermediate-lambda.ss" "lang"))

2
collects/tests/mzscheme/intermediate.ss
View File

@ -20,7 +20,7 @@
(cdr row))) (cdr row)))
docs)) docs))
(define current-htdp-lang '(lib "htdp-intermediate.ss" "lang")) (define current-htdp-lang 'lang/htdp-intermediate)
(load-relative "htdp-test.ss") (load-relative "htdp-test.ss")
(require (lib "htdp-intermediate.ss" "lang")) (require (lib "htdp-intermediate.ss" "lang"))

6
collects/tests/mzscheme/intm-adv.ss
View File

@ -101,10 +101,10 @@
(htdp-syntax-test #'(time (define x 5))) (htdp-syntax-test #'(time (define x 5)))
(htdp-err/rt-test (foldr car 2 '(1 2 3)) (htdp-err/rt-test (foldr car 2 '(1 2 3))
"foldr : first argument must be a <procedure> that accepts two arguments, given #<primitive:car>") "foldr : first argument must be a <procedure> that accepts two arguments, given #<procedure:car>")
(htdp-err/rt-test (foldl car 2 '(1 2 3)) (htdp-err/rt-test (foldl car 2 '(1 2 3))
"foldl : first argument must be a <procedure> that accepts two arguments, given #<primitive:car>") "foldl : first argument must be a <procedure> that accepts two arguments, given #<procedure:car>")
(htdp-err/rt-test (build-string 2 add1) (htdp-err/rt-test (build-string 2 add1)
"build-string : second argument must be a <procedure> that produces a <char>, given #<primitive:add1>, which produced 1 for 0") "build-string : second argument must be a <procedure> that produces a <char>, given #<procedure:add1>, which produced 1 for 0")