From a1be19c0402a42893d917649dfd25bd07fd90b40 Mon Sep 17 00:00:00 2001 From: John Clements Date: Sat, 2 Feb 2008 00:37:42 +0000 Subject: [PATCH] closer to working with v4 svn: r8500 --- collects/tests/stepper/module-elaborator.ss | 117 -------------------- collects/tests/stepper/through-tests.ss | 51 ++++----- 2 files changed, 22 insertions(+), 146 deletions(-) delete mode 100644 collects/tests/stepper/module-elaborator.ss diff --git a/collects/tests/stepper/module-elaborator.ss b/collects/tests/stepper/module-elaborator.ss deleted file mode 100644 index d9ddce2ec3..0000000000 --- a/collects/tests/stepper/module-elaborator.ss +++ /dev/null @@ -1,117 +0,0 @@ -(module module-elaborator mzscheme - - (require (lib "list.ss") - (lib "contract.ss")) - - (provide/contract [wrap-in-module ((listof syntax?) any/c (listof any/c) . -> . (listof syntax?))] ) - - ;; full-on COPIED from plt/collects/lang/htdp-langs.ss - - (define (wrap-in-module exps language-module-spec teachpack-specs) - (let ([new-module-id (gensym "-htdp")]) - (with-syntax ([(tp-spec ...) teachpack-specs]) - (list (let ([mod (expand #`(module #,new-module-id #,language-module-spec - ;; why was this here? (JBC,2007-12-15) - #;(require-for-syntax mzscheme) - (require tp-spec ...) - #,@exps))]) - (rewrite-module mod)) - #`(require (quote #,new-module-id)) -; #`(let ([done-already? #f]) -; (dynamic-wind -; void -; (lambda () (dynamic-require '#,new-module-id #f)) -; (lambda () -; (unless done-already? -; (set! done-already? #t) -; (current-namespace (module->namespace '#,new-module-id)))))) - )))) - - ;; rewrite-module : syntax -> syntax - ;; rewrites te module to provide all definitions and - ;; print out all results. - - (define (rewrite-module stx) - (printf "expanded: ~s\n" stx) - (syntax-case stx (module #%plain-module-begin) - [(module name lang (#%plain-module-begin bodies ...)) - (with-syntax ([(rewritten-bodies ...) - (rewrite-bodies (syntax->list (syntax (bodies ...))))]) - (syntax (module name lang - (#%plain-module-begin - rewritten-bodies ...))))] - [else - (raise-syntax-error 'htdp-languages "internal error .1")])) - - ;; rewrite-bodies : (listof syntax) -> syntax - (define (rewrite-bodies bodies) - (let loop ([bodies bodies] - [ids null]) - (cond - [(null? bodies) - (list - (with-syntax ([(ids ...) ids]) - (syntax (provide ids ...))))] - [else - (let ([body (car bodies)]) - (syntax-case body (define-values define-syntaxes #%require require-for-syntax provide) - [(define-values (new-vars ...) e) - (cons body (loop (cdr bodies) - (append - ids - (filter-ids (syntax (new-vars ...))))))] - [(define-syntaxes (new-vars ...) e) - (cons body (loop (cdr bodies) - (append - ids - (filter-ids (syntax (new-vars ...))))))] - [(#%require specs ...) - (cons body (loop (cdr bodies) ids))] - [(require-for-syntax specs ...) - (cons body (loop (cdr bodies) ids))] - [(provide specs ...) - (loop (cdr bodies) ids)] - [else - (let ([new-exp - (with-syntax ([body body] - [print-results - (lambda (dont-care) - (void) ; intended to simulate the code in drscheme that actually does something. - )]) - (syntax - (call-with-values - (lambda () body) - print-results)))]) - (cons new-exp (loop (cdr bodies) ids)))]))]))) - - (define (filter-ids ids) - ;; When a `define-values' or `define-syntax' declaration - ;; is macro-generated, if the defined name also originates - ;; from a macro, then the name is hidden to anything - ;; that wasn't generated by the same macro invocation. This - ;; hiding relies on renaming at the symbol level, and it's - ;; exposed by the fact that `syntax-e' of the identifier - ;; returns a different name than `identifier-binding'. - (filter - (lambda (id) - (let ([ib (identifier-binding id)]) - ;; ib should always be a 4-elem list, but - ;; check, just in case: - (or (not (pair? ib)) - (eq? (syntax-e id) - (cadr ib))))) - (syntax->list ids))) - - - ; pathetic 'verified-by-inspection' test case: - - `(define test-reader - (let ([done? #f]) - (lambda () - (if done? - eof - (begin - (set! done? #t) - #'(+ 3 4)))))) - `(printf "~a\n" (wrap-in-module test-reader `(lib "htdp-beginner.ss" "lang"))) - ) diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 7dc99f7e6a..9072fe3871 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -3,15 +3,17 @@ ;;exec mred -u "$0" "$@" ;;|# -(module through-tests mzscheme - (require (lib "shared.ss" "stepper" "private") - (lib "model.ss" "stepper" "private") - (lib "model-settings.ss" "stepper" "private") - (lib "match.ss") - (lib "sexp-diff.ss" "tests" "utils") - "module-elaborator.ss" - (lib "list.ss") - (only (lib "13.ss" "srfi") string-contains) +#lang scheme/base + + (require (for-syntax scheme/base) + (for-syntax scheme/mpair) + scheme/match + stepper/private/shared + stepper/private/model + stepper/private/model-settings + tests/utils/sexp-diff + lang/run-teaching-program + (only-in (lib "13.ss" "srfi") string-contains) ;; for xml testing: ;; (lib "class.ss") ;; (all-except (lib "xml-snipclass.ss" "xml") snip-class) @@ -19,9 +21,7 @@ ;; (lib "mred.ss" "mred") ) - (require-for-syntax scheme/mpair) - - (provide (all-defined)) + (provide (all-defined-out)) (define test-directory (find-system-path 'temp-dir)) @@ -31,11 +31,11 @@ (define show-all-steps (make-parameter #f)) - (define (stream-ify expr-list iter) + (define (stream-ify stx-thunk iter) (lambda () - (if (null? expr-list) - (iter eof void) - (iter (expand (car expr-list)) (stream-ify (cdr expr-list) iter))))) + (let* ([next (stx-thunk)] + [followup-thunk (if (eof-object? next) void (stream-ify stx-thunk iter))]) + (iter (expand next) followup-thunk)))) (define (warn who fmt . args) (set-box! (error-has-occurred-box) #t) @@ -63,16 +63,7 @@ [program-expander (lambda (init iter) (init) - (let* ([exps (let read-loop () - (let ([expr (read-syntax "test-input" in-port)]) - (if (eof-object? expr) - null - (cons expr (read-loop)))))] - [exprs (wrap-in-module - exps namespace-spec teachpack-specs)]) - ((stream-ify (let ([ans exprs]) - (printf "~s\n" ans) - ans) iter))))]) + ((stream-ify (expand-teaching-program in-port read-syntax namespace-spec teachpack-specs #f) iter)))]) (let/ec escape (parameterize ([error-escape-handler (lambda () (escape (void)))]) (go program-expander receive-result render-settings @@ -88,6 +79,7 @@ (let ([filename (build-path test-directory "stepper-test")]) (call-with-output-file filename (lambda (port) (fprintf port "~a" exp-str)) + #:exists 'truncate) (unless (display-only-errors) (printf "testing string: ~v\n" exp-str)) @@ -423,7 +415,8 @@ -> {(+ 5 6)} -> {11}) - (t 2armed-if test-mz-sequence + ;; not really a part of base mzscheme anymore + #;(t 2armed-if test-mz-sequence (if 3 4) :: {(if 3 4)} -> {4}) @@ -1665,7 +1658,7 @@ (run-tests '(check-error))) #;(parameterize ([display-only-errors #t]) (run-all-tests-except '(prims qq-splice time set! local-set! lazy1 lazy2 lazy3))) - + (run-all-tests) - ) +