diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index ec2b486120..eca010609c 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -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 diff --git a/collects/scheme/require-transform.ss b/collects/scheme/require-transform.ss index 3b1c00b567..71cc792c70 100644 --- a/collects/scheme/require-transform.ss +++ b/collects/scheme/require-transform.ss @@ -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))]) diff --git a/collects/scribblings/quick/images/exprs.dat b/collects/scribblings/quick/images/exprs.dat index 503673d156..17fbdcd161 100644 --- a/collects/scribblings/quick/images/exprs.dat +++ b/collects/scribblings/quick/images/exprs.dat @@ -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 . "#")))) -(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 . "#")))) +((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]"))))) diff --git a/collects/tests/mzscheme/advanced.ss b/collects/tests/mzscheme/advanced.ss index e9174f6f11..9087e2911c 100644 --- a/collects/tests/mzscheme/advanced.ss +++ b/collects/tests/mzscheme/advanced.ss @@ -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")) diff --git a/collects/tests/mzscheme/beginner-abbr.ss b/collects/tests/mzscheme/beginner-abbr.ss index 8c9f76b732..ecb8962079 100644 --- a/collects/tests/mzscheme/beginner-abbr.ss +++ b/collects/tests/mzscheme/beginner-abbr.ss @@ -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")) diff --git a/collects/tests/mzscheme/beginner.ss b/collects/tests/mzscheme/beginner.ss index 8fd24e36b0..ec61d274d1 100644 --- a/collects/tests/mzscheme/beginner.ss +++ b/collects/tests/mzscheme/beginner.ss @@ -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")) diff --git a/collects/tests/mzscheme/htdp-test.ss b/collects/tests/mzscheme/htdp-test.ss index b8af962290..8a6477f808 100644 --- a/collects/tests/mzscheme/htdp-test.ss +++ b/collects/tests/mzscheme/htdp-test.ss @@ -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))) diff --git a/collects/tests/mzscheme/intermediate-lambda.ss b/collects/tests/mzscheme/intermediate-lambda.ss index b00fafad2b..367ef33ceb 100644 --- a/collects/tests/mzscheme/intermediate-lambda.ss +++ b/collects/tests/mzscheme/intermediate-lambda.ss @@ -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")) diff --git a/collects/tests/mzscheme/intermediate.ss b/collects/tests/mzscheme/intermediate.ss index 920b901cf1..d9c1337cf5 100644 --- a/collects/tests/mzscheme/intermediate.ss +++ b/collects/tests/mzscheme/intermediate.ss @@ -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")) diff --git a/collects/tests/mzscheme/intm-adv.ss b/collects/tests/mzscheme/intm-adv.ss index f7d3f3020c..ff116a24bb 100644 --- a/collects/tests/mzscheme/intm-adv.ss +++ b/collects/tests/mzscheme/intm-adv.ss @@ -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 that accepts two arguments, given #") + "foldr : first argument must be a that accepts two arguments, given #") (htdp-err/rt-test (foldl car 2 '(1 2 3)) - "foldl : first argument must be a that accepts two arguments, given #") + "foldl : first argument must be a that accepts two arguments, given #") (htdp-err/rt-test (build-string 2 add1) - "build-string : second argument must be a that produces a , given #, which produced 1 for 0") + "build-string : second argument must be a that produces a , given #, which produced 1 for 0")