closer to working with v4
svn: r8500
This commit is contained in:
John Clements
parent
4124a601ed
commit
a1be19c040
|
|
@ -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")))
|
||||
)
|
||||
|
|
@ -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)
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user