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
(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)
(unless (module-path? (syntax->datum stx))
(unless (module-path? (syntax->datum (xlate-path stx)))
(raise-syntax-error
#f
"ill-formed module path"
@ -163,16 +182,18 @@
[(eq? mode 'label) #`(for-label #,base)]
[else (error "huh?" mode)]))]
[simple-path? (lambda (p)
(syntax-case p (lib)
(syntax-case p (lib quote)
[(lib . _)
(check-lib-form p)]
[(quote . _)
(check-lib-form p)]
[_
(or (identifier? p)
(and (string? (syntax-e p))
(module-path? (syntax-e p))))]))]
[transform-simple
(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:
[_
(string? (syntax-e in))
@ -185,17 +206,21 @@
in))
(list (mode-wrap base-mode in)))]
[_
(identifier? in)
(and (identifier? in)
(module-path? (syntax-e #'in)))
(list (mode-wrap base-mode in))]
[(quote . s)
(check-lib-form in)
(list (mode-wrap base-mode (xlate-path in)))]
[(lib . s)
(check-lib-form in)
(list (mode-wrap base-mode in))]
(list (mode-wrap base-mode (xlate-path in)))]
[(file . s)
(check-lib-form in)
(list (mode-wrap base-mode in))]
(list (mode-wrap base-mode (xlate-path in)))]
[(planet . s)
(check-lib-form in)
(list (mode-wrap base-mode in))]
(list (mode-wrap base-mode (xlate-path in)))]
[(prefix-in pfx path)
(simple-path? #'path)
(list (mode-wrap
@ -204,7 +229,7 @@
#'path
(syntax-e
(quasisyntax
(prefix pfx path)))
(prefix pfx #,(xlate-path #'path))))
in
in)))]
[(except-in path id ...)
@ -218,7 +243,7 @@
#'path
(syntax-e
(quasisyntax/loc in
(all-except path id ...))))))]
(all-except #,(xlate-path #'path) id ...))))))]
;; General case:
[_ (let-values ([(imports sources) (expand-import in)])
;; TODO: collapse back to simple cases when possible

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

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

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

@ -1,102 +1,102 @@
(0 () 0 () () 5)
(0 () 0 () () 5)
(0 () 0 () () "art gallery")
(0 () 0 () () "art gallery")
(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]")))))
(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]")))))
(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"))
(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]")))))
(0 () 0 () () (c! define c! c c! (c! circle c! 10)))
(0 () 0 () () (void))
(0 () 0 () () (c! define c! r c! (c! rectangle c! 10 c! 20)))
(0 () 0 () () (void))
(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]")))))
(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]")))))
(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]")))))
(0 () 0 () () (c! define c! (c! square c! n) c! (c! filled-rectangle c! n c! n)))
(0 () 0 () () (void))
(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]")))))
(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))
(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]")))))
(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))
(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]")))))
(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))
(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]")))))
(0 () 0 () () circle)
(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))))
(0 () 0 () () (void))
(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]")))))
(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]")))))
(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]")))))
(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))
(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]")))))
(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]")))))
(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))
(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]")))))
(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]")))))
(0 () 0 () () (c! list c! "red" c! "green" c! "blue"))
(0 () 0 () () (c! "red" c! "green" c! "blue"))
(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)))))))
(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))
(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)))))))
(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]")))))
(0 () 0 () () (c! require c! (c! lib c! "flash.ss" c! "texpict")))
(0 () 0 () () (void))
(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]")))))
(0 () 0 () () (c! require c! (c! planet c! "random.ss" c! (c! "schematics" c! "random.plt" c! 1 c! 0))))
(0 () 0 () () (void))
(0 () 0 () () (c! random-gaussian))
(0 () 0 () () 0.9050686838895684)
(0 () 0 () () (c! require c! (c! lib c! "code.ss" c! "slideshow")))
(0 () 0 () () (void))
(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]")))))
(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))
(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]")))))
(0 () 0 () () (c! require c! (c! lib c! "class.ss" c! "mzlib") c! (c! lib c! "mred.ss" c! "mred")))
(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))))))
(0 () 0 () () (void))
(0 () 0 () () (c! send c! f c! show c! #t))
(0 () 0 () () (void))
(0 () 0 () () (c! send c! f c! show c! #f))
(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)))))))
(0 () 0 () () (void))
(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% ...)"))))
(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% ...)"))))
(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) 0 () 0 () () 5)
((1) 0 () 0 () () 5)
((1) 0 () 0 () () "art gallery")
((1) 0 () 0 () () "art gallery")
((1) 0 () 0 () () (c circle c 10))
((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]")))))
((1) 0 () 0 () () (c rectangle c 10 c 20))
((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]")))))
((1) 0 () 0 () () (c circle c 10 c 20))
((1) 1 (((lib "exn.ss" "scribblings" "quick") . deserialize-info:mr-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20"))
((1) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20)))
((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]")))))
((1) 0 () 0 () () (c define c c c (c circle c 10)))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c define c r c (c rectangle c 10 c 20)))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () r)
((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]")))))
((1) 0 () 0 () () (c hc-append c c c r))
((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]")))))
((1) 0 () 0 () () (c hc-append c 20 c c c r c c))
((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]")))))
((1) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n)))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c square c 10))
((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]")))))
((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)))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c four c (c circle c 10)))
((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]")))))
((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))))
((1) 0 () 0 () () (void))
((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")))
((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]")))))
((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))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c checkerboard c (c square c 10)))
((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]")))))
((1) 0 () 0 () () circle)
((1) 1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#<procedure:circle>"))))
((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))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c series c circle))
((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]")))))
((1) 0 () 0 () () (c series c square))
((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]")))))
((1) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size)))))
((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]")))))
((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"))))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c rgb-series c circle))
((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]")))))
((1) 0 () 0 () () (c rgb-series c square))
((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]")))))
((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")))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c series c (c rgb-maker c circle)))
((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]")))))
((1) 0 () 0 () () (c series c (c rgb-maker c square)))
((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]")))))
((1) 0 () 0 () () (c list c "red" c "green" c "blue"))
((1) 0 () 0 () () (c "red" c "green" c "blue"))
((1) 0 () 0 () () (c list c (c circle c 10) c (c square c 10)))
((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)))))))
((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"))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c rainbow c (c square c 5)))
((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)))))))
((1) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5))))
((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]")))))
((1) 0 () 0 () () (c require c texpict/flash))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c filled-flash c 40 c 30))
((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]")))))
((1) 0 () 0 () () (c require c (c planet c "random.ss" c (c "schematics" c "random.plt" c 1 c 0))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c random-gaussian))
((1) 0 () 0 () () 0.9050686838895684)
((1) 0 () 0 () () (c require c (c lib c "code.ss" c "slideshow")))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c code c (c circle c 10)))
((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]")))))
((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))))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c pict+code c (c circle c 10)))
((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]")))))
((1) 0 () 0 () () (c require c (c lib c "class.ss" c "mzlib") c (c lib c "mred.ss" c "mred")))
((1) 0 () 0 () () (void))
((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))))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c send c f c show c #t))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c send c f c show c #f))
((1) 0 () 0 () () (void))
((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)))))))
((1) 0 () 0 () () (void))
((1) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10))))
((1) 1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
((1) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow")))
((1) 1 (((lib "struct.ss" "scribble") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)"))))
((1) 0 () 0 () () (c scale c (c bitmap c "art.png") c 0.5))
((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)))
docs))
(define current-htdp-lang '(lib "htdp-advanced.ss" "lang"))
(define current-htdp-lang 'lang/htdp-advanced)
(load-relative "htdp-test.ss")
(require (lib "htdp-advanced.ss" "lang"))

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

@ -15,10 +15,11 @@
;; Don't need these:
(define no-extra-if-tests? #t)
(require (rename mzscheme exn:fail? exn:fail?)
(rename mzscheme exn:fail:contract? exn:fail:contract?))
(require (only-in mzscheme
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")
(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?))
(define current-htdp-lang '(lib "htdp-beginner.ss" "lang"))
(define current-htdp-lang 'lang/htdp-beginner)
(load-relative "htdp-test.ss")
(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
(cond
[(syntax? v)
(datum->syntax-object
(datum->syntax
#f
(strip-context (syntax-e v))
v
@ -37,21 +37,23 @@
(cond
[(null? teachpack-accum) lang]
[(equal? teachpack-accum previous-tp-accum)
previous-tp-lang]
`',previous-tp-lang]
[else
(let ([name (string->symbol (format "~a+tp~a" lang (gensym)))])
(eval #`(module #,name mzscheme
(define-syntax (bounce stx)
#'(begin
(require #,lang #,@teachpack-accum)
(require #,lang #,@(map (lambda (t)
#`(quote #,t))
teachpack-accum))
(provide (all-from #,lang)
#,@(map (lambda (tp)
#`(all-from #,tp))
#`(all-from (quote #,tp)))
teachpack-accum))))
(bounce)))
(set! previous-tp-accum teachpack-accum)
(set! previous-tp-lang name)
name)]))
`',name)]))
(define htdp-syntax-test
(case-lambda
@ -66,7 +68,8 @@
(require (only-in mzscheme
[let mz-let]
[require mz-require]))
[require mz-require]
[quote mz-quote]))
(define-syntax (htdp-test stx)
(syntax-case stx ()
@ -85,9 +88,9 @@
#`(module #,name #,(add-teachpacks current-htdp-lang)
#,@body-accum
#,(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)]))
(define (htdp-string-to-pred exn?/rx)
@ -106,18 +109,26 @@
(define (htdp-error-test stx)
(do-htdp-test stx #t #f))
(module helper mzscheme
(module helper scheme/base
(require (for-syntax scheme/base))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ the-test lang to-export requires . rest)
#`(#%module-begin
(require (rename tester the-test test))
(require lang . requires)
#,@(if (syntax-object->datum (syntax to-export))
(list (syntax (provide to-export)))
'())
. rest)]))
(provide (rename module-begin #%module-begin)))
[(_ the-test lang mb to-export (tp ...) . rest)
(with-syntax ([(tp ...)
(map (lambda (tp)
(datum->syntax
tp
(list #'quote tp)
tp))
(syntax->list #'(tp ...)))])
#`(#%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
(define test (namespace-variable-value 'test))
@ -126,17 +137,17 @@
(define (do-htdp-test stx stx-err? exn?)
(let ([name (gensym 'm)])
((if stx-err? syntax-test eval)
#`(module #,name helper
#`(module #,name 'helper
test
(all-except #,current-htdp-lang #%module-begin)
#,current-htdp-lang #%module-begin
#f
#,teachpack-accum
#,@body-accum
#,(strip-context stx)))
(unless stx-err?
(if exn?
(err/rt-test (eval #`(mz-require #,name)) exn?)
(eval #`(mz-require #,name))))))
(err/rt-test (eval #`(mz-require '#,name)) exn?)
(eval #`(mz-require '#,name))))))
(define-syntax (htdp-eval stx)
(syntax-case stx ()
@ -145,11 +156,11 @@
(define (do-htdp-eval stx)
(let ([name (gensym 'm)])
(eval
#`(module #,name helper
#`(module #,name 'helper
test
(all-except #,current-htdp-lang #%module-begin)
#,current-htdp-lang #%module-begin
the-answer
#,teachpack-accum
#,@body-accum
(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)))
docs))
(define current-htdp-lang '(lib "htdp-intermediate-lambda.ss" "lang"))
(define current-htdp-lang 'lang/htdp-intermediate-lambda)
(load-relative "htdp-test.ss")
(require (lib "htdp-intermediate-lambda.ss" "lang"))

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

@ -20,7 +20,7 @@
(cdr row)))
docs))
(define current-htdp-lang '(lib "htdp-intermediate.ss" "lang"))
(define current-htdp-lang 'lang/htdp-intermediate)
(load-relative "htdp-test.ss")
(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-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))
"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)
"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")