...
svn: r16455
This commit is contained in:
John Clements
parent
cf78f9173c
commit
0263431ae0
|
|
@ -1,706 +0,0 @@
|
|||
(require (prefix annotate: stepper/private/annotate))
|
||||
(require (prefix kernel: syntax/kerncase))
|
||||
(require drscheme/private/syncheck-debug)
|
||||
(require stepper/private/marks)
|
||||
(require "tests-common.ss")
|
||||
|
||||
(load "/Users/clements/plt/tests/mzscheme/testing.ss")
|
||||
|
||||
(reset-namespaces)
|
||||
|
||||
(SECTION 'stepper-annotater)
|
||||
|
||||
|
||||
; check-mark : test the validity of a mark. the symbols in 'binding-ids' must be included. the symbols
|
||||
; in excluded-ids must not appear in the list. If binding-ids is 'all, then no symbols other than those
|
||||
; in the binding-ids may appear.
|
||||
;
|
||||
; note: cheap hack: if a string is supplied rather than a symbol in binding-ids, it passes if the string
|
||||
; is a prefix of (symbol->string) of one of the present symbols.
|
||||
; (syntax-object (listof (union symbol string)) (union (listof symbol) 'all) -> void)
|
||||
|
||||
(define (binding-match? input actual)
|
||||
(if (string? input)
|
||||
(and (>= (string-length (symbol->string actual)) (string-length input))
|
||||
(string=? (substring (symbol->string actual) 0 (string-length input)) input))
|
||||
(eq? input actual)))
|
||||
|
||||
(define (check-mark mark-stx binding-ids excluded-ids)
|
||||
(let* ([bindings (syntax-case mark-stx (lambda )
|
||||
[(lambda ()
|
||||
(mark-maker
|
||||
source
|
||||
label
|
||||
. bindings))
|
||||
(let loop ([binding-list (syntax->list (syntax bindings))])
|
||||
(cond [(null? binding-list) null]
|
||||
[(null? (cdr binding-list))
|
||||
(error 'check-mark "odd number of elements in binding list: ~a" (syntax-object->datum (syntax bindings)))]
|
||||
[else
|
||||
(let* ([quoted-stx (stx-protector-stx (syntax-e (cadr binding-list)))])
|
||||
(when (not (module-identifier=?
|
||||
(car binding-list)
|
||||
quoted-stx))
|
||||
(error 'check-mark "binding pair does not match: ~a, ~a" (syntax-object->datum (car binding-list))
|
||||
(syntax-object->datum (cadr binding-list))))
|
||||
(when (not (identifier? (car binding-list)))
|
||||
(error 'check-mark "syntax object is not an identifier: ~a" (syntax-object->datum (car bindings-list))))
|
||||
(cons (syntax-e (car binding-list))
|
||||
(loop (cddr binding-list))))]))])])
|
||||
(let loop ([remaining bindings])
|
||||
(unless (null? remaining)
|
||||
(when (memq (car remaining) (cdr remaining))
|
||||
(error 'check-mark "binding ~a appears twice in binding-list: ~a" (car remaining) bindings))
|
||||
(loop (cdr remaining))))
|
||||
(for-each (lambda (desired)
|
||||
(unless (ormap (lambda (binding)
|
||||
(binding-match? desired binding))
|
||||
bindings)
|
||||
(error 'check-mark "binding ~a not contained in binding-list: ~a" desired bindings)))
|
||||
binding-ids)
|
||||
(if (eq? excluded-ids 'all)
|
||||
(for-each (lambda (binding)
|
||||
(unless (ormap (lambda (binding-id)
|
||||
(binding-match? binding-id binding))
|
||||
binding-ids)
|
||||
(error 'check-mark "binding ~a does not appear in desired list: ~a" binding binding-ids)))
|
||||
bindings)
|
||||
(for-each (lambda (not-desired)
|
||||
(when (memq not-desired bindings)
|
||||
(error 'check-mark "excluded binding ~a contained in binding-list: ~a" not-desired bindings)))
|
||||
excluded-ids))))
|
||||
|
||||
; test cases
|
||||
|
||||
(syntax-case (expand #'(let ([a 1] [b 2]) (begin a b))) (let-values begin)
|
||||
[(let-values bindings a b)
|
||||
(begin
|
||||
(err/rt-test (check-mark (let* ([a-var #'a]) (make-full-mark #'3 'a (list a-var a-var))) '() '()) exn:user?) ; binding appears twice
|
||||
(test (void) check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a b) 'all)
|
||||
(err/rt-test (check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a b c) 'all) exn:user?) ; c isn't there
|
||||
(err/rt-test (check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) 'all) exn:user?) ; bad 'all
|
||||
(test (void) check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) '(c))
|
||||
(err/rt-test (check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) '(b c)) exn:user?) ; b is there
|
||||
(test (void) check-mark (make-full-mark #'3 'a (list #'a #'b)) '(a) '())
|
||||
(test (void) check-mark (make-full-mark #'3 'a (list #'arg0-436 #'c)) '("arg0" c) '())
|
||||
(err/rt-test (check-mark (make-full-mark #'3 'a (list #'arg0-436 #'c)) '("djs") '()) exn:user?))])
|
||||
|
||||
; syntax-symbol=? : compares a list of symbols to a given symbol (or to each other if sym = #f)
|
||||
; (union symbol #f) (listof syntax-object) -> boolean
|
||||
|
||||
(define (syntax-symbol=? sym lostx)
|
||||
(if sym
|
||||
(andmap (lambda (stx) (eq? sym (syntax-e stx))) lostx)
|
||||
(if (pair? lostx)
|
||||
(andmap (lambda (stx) (eq? (syntax-e stx) (syntax-e (car lostx)))) lostx)
|
||||
#t)))
|
||||
|
||||
(define (wrap-expand-unwrap stx language-level-spec)
|
||||
(let* ([wrapped (datum->syntax-object #f `(module test-module ,language-level-spec
|
||||
,@stx))]
|
||||
[expanded (expand wrapped)])
|
||||
(with-syntax ([(module name lang (_ . exprs)) expanded])
|
||||
(syntax->list (syntax exprs)))))
|
||||
|
||||
(test '((if (#%app verify-boolean (#%datum . 3) 'if) (#%datum . 4) (#%datum . 5)))
|
||||
map syntax-object->datum (wrap-expand-unwrap (list #'(if 3 4 5)) '(lib "htdp-beginner.ss" "lang")))
|
||||
|
||||
(define (annotate-exprs-no-break stx-list)
|
||||
(annotate-exprs (map expand stx-list) void))
|
||||
|
||||
(define (namespace-annotate-expr stx namespace)
|
||||
;(when (syntax? stx)
|
||||
; (error 'namespace-rewrite-expr "namespace-rewrite-expr accepts s-exps, not syntax-objects"))
|
||||
(parameterize ([current-namespace namespace])
|
||||
(let*-values ([(annotated new-env)
|
||||
(annotate:annotate (expand stx) annotate:initial-env-package break 'foot-wrap)])
|
||||
annotated)))
|
||||
|
||||
; the following procedure is used to test just the top-level-rewrite part of the annotater:
|
||||
|
||||
(define (namespace-rewrite-expr stx namespace)
|
||||
;(when (syntax? stx)
|
||||
; (error 'namespace-rewrite-expr "namespace-rewrite-expr accepts s-exps, not syntax-objects"))
|
||||
(parameterize ([current-namespace namespace])
|
||||
(annotate:top-level-rewrite (expand stx))))
|
||||
|
||||
; strip-outer-lambda takes off a lambda wrapped around a test expression. For testing purposes,
|
||||
; we often want to establish lexical bindings, then strip them off to check the test expr
|
||||
|
||||
(define (strip-outer-lambda stx)
|
||||
(syntax-case stx (lambda begin with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
debug-key-1
|
||||
debug-mark-1
|
||||
(closure-storing-proc
|
||||
(lambda args
|
||||
content)
|
||||
debug-mark-2))
|
||||
(syntax content)]))
|
||||
|
||||
|
||||
; test case:
|
||||
(test #t
|
||||
(lambda ()
|
||||
(syntax-case (strip-outer-lambda (car (annotate-exprs-no-break (list #'(lambda (a b c) 3)))))
|
||||
(with-continuation-mark lambda quote-syntax #%datum)
|
||||
[(with-continuation-mark
|
||||
key
|
||||
bogus-key
|
||||
(begin
|
||||
break-proc-1
|
||||
(#%datum . 3)))
|
||||
#t])))
|
||||
|
||||
(define (strip-return-value-wrap stx)
|
||||
(syntax-case stx (let*)
|
||||
[(let* ([result-var-0 expr])
|
||||
break-0
|
||||
result-var-1)
|
||||
(begin
|
||||
(test 'result syntax-e (syntax result-var-0))
|
||||
(test 'result syntax-e (syntax result-var-1))
|
||||
(syntax expr))]))
|
||||
|
||||
(test 'a syntax-e
|
||||
(strip-return-value-wrap
|
||||
(syntax-case (car (annotate-exprs-no-break (list #'a))) (with-continuation-mark begin)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
break-0
|
||||
expr))
|
||||
(syntax expr)])))
|
||||
|
||||
; test notes to myself:
|
||||
; the never-undefined property can only be tested in the non-foot-wrap modes
|
||||
; hard to test 3D values like closure-capturing-proc
|
||||
; hard to test whether the source pointer is right.
|
||||
|
||||
(define test-cases
|
||||
; begin
|
||||
(list (list (list #'(lambda (a b c) (begin a b (begin a c))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (with-continuation-mark begin)
|
||||
[(with-continuation-mark
|
||||
debug-key-1
|
||||
debug-mark-1
|
||||
(begin
|
||||
pre-break-1
|
||||
(begin
|
||||
(with-continuation-mark
|
||||
debug-key-2
|
||||
debug-mark-2
|
||||
a-var-0)
|
||||
(with-continuation-mark
|
||||
debug-key-3
|
||||
debug-mark-3
|
||||
b-var-0)
|
||||
(with-continuation-mark
|
||||
debug-key-4
|
||||
debug-mark-4
|
||||
begin-body-4))))
|
||||
(begin
|
||||
(test 'a syntax-e (syntax a-var-0))
|
||||
(test 'b syntax-e (syntax b-var-0))
|
||||
(test (void) check-mark (syntax debug-mark-1) '(a b c) 'all)
|
||||
(test (void) check-mark (syntax debug-mark-2) '() 'all)
|
||||
(test (void) check-mark (syntax debug-mark-3) '() 'all)
|
||||
(test (void) check-mark (syntax debug-mark-4) '(a c) 'all))])))
|
||||
|
||||
; lambda : general test
|
||||
(list (list #'(lambda (a b) (lambda (b c) (+ b c) (+ a b 4))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (with-continuation-mark begin lambda)
|
||||
[(with-continuation-mark
|
||||
debug-key
|
||||
debug-mark-1
|
||||
(begin
|
||||
pre-break-1
|
||||
(closure-capturing-proc
|
||||
(lambda (b c)
|
||||
(with-continuation-mark
|
||||
debug-key-2
|
||||
debug-mark-lambda-body
|
||||
(begin
|
||||
pre-break-2
|
||||
(begin
|
||||
. begin-bodies))))
|
||||
debug-mark-3)))
|
||||
(begin (test (void) check-mark (syntax debug-mark-1) '(a) 'all)
|
||||
(test (void) check-mark (syntax debug-mark-3) '(a) 'all))])))
|
||||
|
||||
; improper arg-list:
|
||||
(list (list #'(lambda (a b . c) (begin b c)))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (with-continuation-mark begin lambda)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(closure-capturing-proc
|
||||
(lambda (a b . c)
|
||||
(with-continuation-mark
|
||||
key-1
|
||||
mark-1
|
||||
body))
|
||||
mark-2))
|
||||
(begin (test (void) check-mark (syntax mark-0) '() 'all)
|
||||
(test (void) check-mark (syntax mark-1) '(b c) 'all)
|
||||
(test (void) check-mark (syntax mark-2) '() 'all))])))
|
||||
|
||||
; test of lambda's one-label inferred-names :
|
||||
(list (list #'(define (a x) (+ x 1)))
|
||||
(lambda (stx)
|
||||
(kernel:kernel-syntax-case stx #f
|
||||
[(define-values (a)
|
||||
(with-continuation-mark
|
||||
debug-key
|
||||
debug-mark
|
||||
(closure-capturing-proc
|
||||
lambda-exp
|
||||
closure-info)))
|
||||
(test 'a syntax-property (syntax lambda-exp) 'inferred-name)])))
|
||||
|
||||
; test of lambda's cons-pair inferred-names (that is, with lifting):
|
||||
(list (list #'(let ([a (lambda (x) (+ x 1))]) 3))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (let*-values with-continuation-mark begin set!-values set!)
|
||||
[(let*-values _c
|
||||
(with-continuation-mark debug-key_1 debug_mark_1
|
||||
;(begin
|
||||
; (break-proc_1)
|
||||
(begin
|
||||
(set!-values a-label
|
||||
(with-continuation-mark
|
||||
debug-key
|
||||
debug-mark
|
||||
(closure-capturing-proc
|
||||
lambda-exp
|
||||
closure-info
|
||||
lifter-val)))
|
||||
(set! counter 1)
|
||||
body)
|
||||
; )
|
||||
))
|
||||
(test 'a syntax-property (syntax lambda-exp) 'inferred-name)])))
|
||||
|
||||
; case-lambda
|
||||
(list (list #'(lambda (d e) (case-lambda ((b) b d) ((c) c e))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (with-continuation-mark lambda quote-syntax)
|
||||
[(with-continuation-mark
|
||||
debug-key
|
||||
debug-mark-1
|
||||
(begin
|
||||
pre-break-1
|
||||
(closure-storing-proc
|
||||
(case-lambda ((b) . bodies_1)
|
||||
((c) . bodies_2))
|
||||
closure-info)))
|
||||
(test (void) check-mark (syntax debug-mark-1) '(d e) '(b c))])))
|
||||
|
||||
; if
|
||||
(list (list #'(lambda (a b c d) (if (a b) (a c) (a d))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (with-continuation-mark if let-values begin let)
|
||||
[(let ([test-0 *unevaluated*-0])
|
||||
(with-continuation-mark
|
||||
debug-key_1
|
||||
debug-mark-1
|
||||
(begin
|
||||
pre-break-1
|
||||
(begin
|
||||
(set! test-1 (let-values temp-bindings
|
||||
(with-continuation-mark
|
||||
debug-key_2
|
||||
debug-mark-test
|
||||
. test-clauses)))
|
||||
(break-0)
|
||||
(if test-2
|
||||
(let-values temp-bindings_2
|
||||
(with-continuation-mark
|
||||
debug-key_3
|
||||
debug-mark-then
|
||||
. then-clauses))
|
||||
(let-values temp-bindings-3
|
||||
(with-continuation-mark
|
||||
debug-key-4
|
||||
debug-mark-else
|
||||
. else-clauses)))))))
|
||||
(begin
|
||||
(test 'if-temp syntax-e (syntax test-0))
|
||||
(test 'if-temp syntax-e (syntax test-1))
|
||||
(test 'if-temp syntax-e (syntax test-2))
|
||||
(test (void) check-mark (syntax debug-mark-1) '(a b c d if-temp) '())
|
||||
(test (void) check-mark (syntax debug-mark-test) '() '(a b c d if-temp))
|
||||
(test (void) check-mark (syntax debug-mark-then) '(a c) '(b d if-temp))
|
||||
(test (void) check-mark (syntax debug-mark-else) '(a d) '(b c if-temp)))])))
|
||||
|
||||
; one-armed if
|
||||
(list (list #'(lambda (a b c) (if (begin a b) (begin a c))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (with-continuation-mark if let-values begin)
|
||||
[(let ([test-0 *unevaluated*-0])
|
||||
(with-continuation-mark
|
||||
debug-key-1
|
||||
debug-mark-1
|
||||
(begin
|
||||
pre-break-1
|
||||
(begin
|
||||
(set! test-1 (with-continuation-mark
|
||||
debug-key_2
|
||||
debug-mark-test
|
||||
. test-clauses))
|
||||
(break-0)
|
||||
(if test-2
|
||||
(with-continuation-mark
|
||||
debug-key_3
|
||||
debug-mark-then
|
||||
. then-clauses))))))
|
||||
(begin
|
||||
(test 'if-temp syntax-e (syntax test-0))
|
||||
(test 'if-temp syntax-e (syntax test-1))
|
||||
(test 'if-temp syntax-e (syntax test-2))
|
||||
(test (void) check-mark (syntax debug-mark-1) '(a b c if-temp) 'all)
|
||||
(test (void) check-mark (syntax debug-mark-test) '() 'all)
|
||||
(test (void) check-mark (syntax debug-mark-then) '(a c ) 'all))])))
|
||||
|
||||
; top-level begin
|
||||
(list (list #'(begin (define a 3) (begin (begin a))))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (begin with-continuation-mark define-values)
|
||||
[(begin
|
||||
(define-values . rest)
|
||||
(begin
|
||||
(begin
|
||||
(with-continuation-mark key-3 mark-3 (begin var-break-1 a-exp-3)))))
|
||||
(test 'a syntax-e (strip-return-value-wrap (syntax a-exp-3)))])))
|
||||
|
||||
; begin0
|
||||
(list (list #'(lambda (a b) (begin0 a b)))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (begin begin0 with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
pre-break-0
|
||||
(begin0
|
||||
(with-continuation-mark
|
||||
key-result
|
||||
mark-result
|
||||
result-expr)
|
||||
(with-continuation-mark
|
||||
key-other
|
||||
mark-other
|
||||
other-expr))))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '(a b) 'all)
|
||||
(test (void) check-mark (syntax mark-result) '() 'all)
|
||||
(test (void) check-mark (syntax mark-other) '() 'all))])))
|
||||
|
||||
; begin0 : inferred-name transfer
|
||||
(list (list #'(define-values (a) (begin0 (lambda () 3) 4)))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (begin0 define-values with-continuation-mark)
|
||||
[(define-values names
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin0
|
||||
(with-continuation-mark
|
||||
key-1
|
||||
mark-1
|
||||
(procedure-capturing-proc
|
||||
procedure
|
||||
mark-2))
|
||||
. rest)))
|
||||
(test 'a syntax-property (syntax procedure) 'inferred-name)])))
|
||||
; let
|
||||
(list (list #'(lambda (a b c) (let* ([d b] [e (begin a d)]) (begin a b c d))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (begin with-continuation-mark let*-values set!-values set!)
|
||||
[(let*-values bindings
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
pre-break-0
|
||||
;(begin
|
||||
; break-1
|
||||
(begin
|
||||
(set!-values vars-0 (with-continuation-mark key-1 mark-1 body-1))
|
||||
(set! let-counter-0 1)
|
||||
(set!-values vars-1 (with-continuation-mark key-2 mark-2 body-2))
|
||||
(set! let-counter-1 2)
|
||||
;(begin
|
||||
; break-2
|
||||
body-3
|
||||
; )
|
||||
)
|
||||
; )
|
||||
)))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '(a b c d e lifter-d-1 lifter-e-2 let-counter) 'all)
|
||||
(test '(d) syntax-object->datum (syntax vars-0))
|
||||
(test '(e) syntax-object->datum (syntax vars-1))
|
||||
(test (void) check-mark (syntax mark-1) '() 'all)
|
||||
(test (void) check-mark (syntax mark-2) '() 'all))])))
|
||||
|
||||
; letrec --- the only thing that needs to be tested with letrec is that the undefined value is properly used.
|
||||
|
||||
; set!
|
||||
(list (list #'(lambda (a b c) (set! a (begin b c))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (begin with-continuation-mark set!)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
pre-break-0
|
||||
(set! var (with-continuation-mark key-1 mark-1 body))))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '(a b c) 'all)
|
||||
(test 'a syntax-object->datum (syntax var))
|
||||
(test (void) check-mark (syntax mark-1) '() 'all))])))
|
||||
|
||||
; set! with top-level-var
|
||||
(list (list #'(set! a 9))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set! with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(set! var val))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '(a) 'all)
|
||||
(test 'a syntax-e (syntax var)))])))
|
||||
|
||||
; quote
|
||||
(list (list #'(quote a))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (quote with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(quote sym))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '() 'all)
|
||||
(test 'a syntax-e (syntax sym)))])))
|
||||
|
||||
; quote-syntax
|
||||
(list (list #'(quote-syntax a))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (quote-syntax with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(quote-syntax sym))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '() 'all)
|
||||
(test 'a syntax-e (syntax sym)))])))
|
||||
|
||||
; wcm is explicitly not working (as opposed to _lots_ of other forms, which simply won't work in
|
||||
; a stepper sense. Begin0, for example. I think. And set!. etc., etc.
|
||||
|
||||
; application
|
||||
|
||||
(list (list #'(lambda (a b c) (a b)))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (let-values with-continuation-mark begin set!)
|
||||
[(let-values arg-temps
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
pre-break-0
|
||||
(begin
|
||||
(set! var-0 (with-continuation-mark key-1 mark-1 sym-1))
|
||||
(set! var-1 (with-continuation-mark key-2 mark-2 sym-2))
|
||||
(begin
|
||||
break-0
|
||||
(with-continuation-mark key-3 mark-3 (sym-3 sym-4)))))))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '(a b "arg0" "arg1") 'all)
|
||||
(test "arg0" substring (symbol->string (syntax-e (syntax var-0))) 0 4)
|
||||
(test (void) check-mark (syntax mark-1) '() 'all)
|
||||
(test 'a syntax-e (syntax sym-1))
|
||||
(test "arg1" substring (symbol->string (syntax-e (syntax var-1))) 0 4)
|
||||
(test (void) check-mark (syntax mark-2) '() 'all)
|
||||
(test 'b syntax-e (syntax sym-2))
|
||||
(test (void) check-mark (syntax mark-3) '("arg0" "arg1") 'all)
|
||||
(test "arg0" substring (symbol->string (syntax-e (syntax sym-3))) 0 4)
|
||||
(test "arg1" substring (symbol->string (syntax-e (syntax sym-4))) 0 4))])))
|
||||
|
||||
; application with return-wrap
|
||||
(list (list #'(+ 3 4))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (let-values with-continuation-mark begin set!)
|
||||
[(let-values arg-temps
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
(set! var-1 rhs-1)
|
||||
(set! var-2 rhs-2)
|
||||
(set! var-3 rhs-3)
|
||||
(begin
|
||||
break-0
|
||||
(with-continuation-mark
|
||||
key-3
|
||||
mark-3
|
||||
result-expr)))))
|
||||
(syntax-case (strip-return-value-wrap (syntax result-expr)) ()
|
||||
[(var-4 var-5 var-6)
|
||||
(begin
|
||||
(test "arg0" substring (symbol->string (syntax-e (syntax var-4))) 0 4)
|
||||
(test "arg1" substring (symbol->string (syntax-e (syntax var-5))) 0 4)
|
||||
(test "arg2" substring (symbol->string (syntax-e (syntax var-6))) 0 4))])])))
|
||||
|
||||
; application with non-var in fun pos
|
||||
(list (list #'(4 3 4))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (let-values with-continuation-mark begin set!)
|
||||
[(let-values arg-temps
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
(set! var-1 rhs-1)
|
||||
(set! var-2 rhs-2)
|
||||
(set! var-3 rhs-3)
|
||||
(begin
|
||||
break-0
|
||||
(with-continuation-mark key-3 mark-3 (var-4 var-5 var-6))))))
|
||||
(begin
|
||||
(test "arg0" substring (symbol->string (syntax-e (syntax var-4))) 0 4)
|
||||
(test "arg1" substring (symbol->string (syntax-e (syntax var-5))) 0 4)
|
||||
(test "arg2" substring (symbol->string (syntax-e (syntax var-6))) 0 4))])))
|
||||
|
||||
; datum
|
||||
(list (list #'3)
|
||||
(lambda (stx)
|
||||
(syntax-case stx (with-continuation-mark #%datum)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(#%datum . 3))
|
||||
#t])))
|
||||
|
||||
; define-values
|
||||
(list (list #'(define-values (a b) b))
|
||||
(lambda (stx)
|
||||
(syntax-case stx (with-continuation-mark define-values)
|
||||
[(define-values (sym-0 sym-1)
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
body))
|
||||
(begin
|
||||
(test 'a syntax-e (syntax sym-0))
|
||||
(test 'b syntax-e (syntax sym-1))
|
||||
(test (void) check-mark (syntax mark-0) '() 'all))])))
|
||||
|
||||
; top-level vars
|
||||
(list (list #'a)
|
||||
(lambda (stx)
|
||||
(syntax-case stx (begin with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
break-0
|
||||
body))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '() 'all)
|
||||
(test 'a syntax-e (strip-return-value-wrap (syntax body))))])))
|
||||
|
||||
; lexical vars
|
||||
(list (list #'(lambda (a b) a))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (begin with-continuation-mark)
|
||||
[(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
pre-break-0
|
||||
sym-0))
|
||||
(begin
|
||||
(test (void) check-mark (syntax mark-0) '(a) 'all)
|
||||
(test 'a syntax-e (syntax sym-0)))])))
|
||||
|
||||
; correct labelling of variables:
|
||||
(list (list #'(lambda (b) (let ([a 13]) (begin a b))))
|
||||
(lambda (stx)
|
||||
(syntax-case (strip-outer-lambda stx) (begin with-continuation-mark let*-values set!-values)
|
||||
[(let*-values bindings
|
||||
(with-continuation-mark
|
||||
key-0
|
||||
mark-0
|
||||
(begin
|
||||
pre-break-0
|
||||
;(begin
|
||||
; break-0
|
||||
(begin
|
||||
(set!-values (a-var-0) rest0)
|
||||
(set! counter-0 1)
|
||||
;(begin
|
||||
; break-1
|
||||
(with-continuation-mark
|
||||
key-1
|
||||
mark-1
|
||||
(begin
|
||||
(with-continuation-mark key-2 mark-2 (begin break-2 a-var-1))
|
||||
(with-continuation-mark key-3 mark-3 (begin pre-break-1 b-var-0))))
|
||||
; )
|
||||
)
|
||||
; )
|
||||
)))
|
||||
(begin
|
||||
(test 'a syntax-e (syntax a-var-0))
|
||||
(test 'a syntax-e (strip-return-value-wrap (syntax a-var-1)))
|
||||
(test 'b syntax-e (syntax b-var-0))
|
||||
(test 'let-bound stepper-syntax-property (syntax a-var-0) 'stepper-binding-type)
|
||||
(test 'let-bound stepper-syntax-property (strip-return-value-wrap (syntax a-var-1)) 'stepper-binding-type)
|
||||
(test 'lambda-bound stepper-syntax-property (syntax b-var-0) 'stepper-binding-type)
|
||||
)])))
|
||||
|
||||
|
||||
))
|
||||
|
||||
(for-each (lambda (test-case)
|
||||
((cadr test-case) (car (annotate-exprs-no-break (car test-case)))))
|
||||
test-cases)
|
||||
|
||||
;(namespace-annotate-expr '(or 3 4 5) beginner-namespace)
|
||||
|
||||
(syntax-case (namespace-rewrite-expr '(lambda (a) a) mz-namespace) (lambda)
|
||||
[(lambda (a-var-0) a-var-1)
|
||||
(begin
|
||||
(test 'lambda-bound stepper-syntax-property (syntax a-var-0) 'stepper-binding-type)
|
||||
(test 'lexical identifier-binding (syntax a-var-0))
|
||||
(test 'lambda-bound stepper-syntax-property (syntax a-var-1) 'stepper-binding-type)
|
||||
(test 'lexical identifier-binding (syntax a-var-1)))])
|
||||
|
||||
(syntax-case (namespace-rewrite-expr (datum->syntax-object #'here '(case-lambda ((a) a) ((a b) b))) mz-namespace) (case-lambda)
|
||||
[(case-lambda ((a-0) a-1) ((a-2 b-0) b-1))
|
||||
(begin
|
||||
(test 'lexical identifier-binding (syntax b-0))
|
||||
(test 'lexical identifier-binding (syntax b-1)))])
|
||||
|
||||
;(syntax-case (car (namespace-rewrite-expr "(or true false true)" beginner-namespace)) (let-values if)
|
||||
; [(let-values ([(or-part-0) true-0]) (if or-part-1 or-part-2 rest))
|
||||
; (begin
|
||||
; (test 'or-part syntax-e (syntax or-part-0))
|
||||
; (test 'let-bound stepper-syntax-property (syntax or-part-0) 'stepper-binding-type)
|
||||
; (test 'or-part syntax-e (syntax or-part-1))
|
||||
; (test 'let-bound stepper-syntax-property (syntax or-part-1) 'stepper-binding-type))])
|
||||
|
||||
(parameterize ([current-namespace beginner-namespace])
|
||||
(err/rt-test (eval (car (annotate-exprs-no-break (string->stx-list "(define first 3)")))) exn:user?))
|
||||
|
||||
;(test 7 eval (car (annotate-exprs-no-break (list #'(begin (+ 3 4) (+ 4 5))))))
|
||||
;(test 9 eval (car (annotate-exprs-no-break (list #'(begin (+ 3 4) (+ 4 5))))))
|
||||
|
||||
(report-errs)
|
||||
|
|
@ -1,554 +0,0 @@
|
|||
(require (prefix annotate: stepper/private/annotate)
|
||||
(prefix kernel: syntax/kerncase)
|
||||
(prefix reconstruct: stepper/private/reconstruct)
|
||||
stepper/private/shared
|
||||
stepper/private/highlight-placeholder
|
||||
stepper/private/my-macros
|
||||
stepper/private/model-settings
|
||||
stepper/private/marks
|
||||
mzlib/class
|
||||
mzlib/etc
|
||||
"tests-common.ss")
|
||||
|
||||
(load "/Users/clements/plt/tests/mzscheme/testing.ss")
|
||||
|
||||
(SECTION 'stepper-reconstruct)
|
||||
|
||||
(reset-namespaces)
|
||||
|
||||
; this following code is probably a good idea, but not right now. For now, I just want
|
||||
; to get the stepper working.
|
||||
|
||||
;; a step-queue object collects steps that come from
|
||||
;; breakpoints, and sends them to the view in nice
|
||||
;; tidy little bundles
|
||||
;(define step-queue%
|
||||
; (class object% ()
|
||||
;
|
||||
; (field (queue #f)) ; : (listof (list syntax symbol mark-list (listof TST)))
|
||||
;
|
||||
; ; : (syntax symbol mark-list (listof TST)) -> (void)
|
||||
; ; effects: queue
|
||||
; (define (add-step . args)
|
||||
; (set! queue (append queue (list args)))
|
||||
; (try-match))
|
||||
;
|
||||
; ; ( -> (void))
|
||||
; ; effects: queue
|
||||
; ; take action based on the head of the queue
|
||||
; (define (try-match)
|
||||
; (unless (null? queue)
|
||||
; (case (cadr (car queue))
|
||||
; ((
|
||||
;
|
||||
|
||||
; collect-in-pairs-maker : ((list 'a 'a) -> 'b) -> (boolean 'a -> (union 'b void))
|
||||
(define (collect-in-pairs-maker action)
|
||||
(let ([stored-first #f]
|
||||
[have-first? #f])
|
||||
(lambda (first-kind? value)
|
||||
(if first-kind?
|
||||
(begin
|
||||
(set! stored-first value)
|
||||
(set! have-first? #t))
|
||||
(let ([temp-stored stored-first]
|
||||
[temp-have? have-first?])
|
||||
(set! stored-first #f)
|
||||
(set! have-first? #f)
|
||||
(if temp-have?
|
||||
(action (list temp-stored value))
|
||||
(action (list no-sexp value))))))))
|
||||
|
||||
(define t (collect-in-pairs-maker (lx _)))
|
||||
(test (list no-sexp 'ahe) t #f 'ahe)
|
||||
(test (void) t #t 13)
|
||||
(test (void) t #t 'apple)
|
||||
(test (list 'apple 'banana) t #f 'banana)
|
||||
(test (list no-sexp 'oetu) t #f 'oetu)
|
||||
|
||||
; : ((recon-result recon-result -> (void)) box -> syntax -> break-contract)
|
||||
(define (make-break action expr-box)
|
||||
(let* ([recon-call (lx (if (eq? _ no-sexp) `((...) ()) (apply reconstruct:reconstruct-current _)))]
|
||||
[pair-action (lambda (2-list)
|
||||
(unless (eq? (car 2-list) skipped-step)
|
||||
(apply action (map recon-call 2-list))))]
|
||||
[collector (collect-in-pairs-maker pair-action)])
|
||||
(lambda (mark-set break-kind returned-value-list)
|
||||
(let ([mark-list (extract-mark-list mark-set)])
|
||||
(if (reconstruct:skip-step? break-kind mark-list)
|
||||
(when (eq? break-kind 'normal-break)
|
||||
(collector #t skipped-step))
|
||||
(case break-kind
|
||||
((normal-break)
|
||||
(collector #t (list (unbox expr-box) mark-list break-kind returned-value-list)))
|
||||
((result-exp-break result-value-break)
|
||||
(collector #f (list (unbox expr-box) mark-list break-kind returned-value-list)))
|
||||
(else (error 'break "unexpected break-kind: ~a" break-kind))))))))
|
||||
|
||||
|
||||
(define (test-sequence stx expected-queue expected-completed namespace)
|
||||
(let/ec k
|
||||
(let* ([expr-box (box #f)]
|
||||
[action (lambda (before after)
|
||||
(when (null? expected-queue)
|
||||
(when expected-completed
|
||||
(fprintf (current-error-port) "got an extra pair:\nbefore: ~e\nafter: ~e\n"
|
||||
before after)
|
||||
(test #f (lambda (x) x) expected-completed))
|
||||
(k (void)))
|
||||
(test (car expected-queue) (lambda () before))
|
||||
(test (cadr expected-queue) (lambda () after))
|
||||
(set! expected-queue (cddr expected-queue)))])
|
||||
(parameterize ([current-namespace namespace])
|
||||
(let* ([stx-list (string->stx-list stx)]
|
||||
[expanded (map expand stx-list)]
|
||||
[annotated (annotate-exprs expanded (make-break action expr-box))]
|
||||
[eval-expr (lambda (expanded annotated)
|
||||
(set-box! expr-box expanded)
|
||||
(reconstruct:reconstruct-completed expanded (eval annotated)))])
|
||||
(if expected-completed
|
||||
(test expected-completed map eval-expr expanded annotated)
|
||||
(map eval-expr expanded annotated))
|
||||
(test #t null? expected-queue))))))
|
||||
|
||||
(define (namespace-rewrite-expr stx namespace)
|
||||
(parameterize ([current-namespace namespace])
|
||||
(map annotate:top-level-rewrite (map expand (string->stx-list stx)))))
|
||||
|
||||
(define mz-render-settings fake-mz-render-settings)
|
||||
(define (test-mz-sequence source-list result-list)
|
||||
(reconstruct:set-render-settings! mz-render-settings)
|
||||
(test-sequence source-list result-list #f mz-namespace))
|
||||
|
||||
(define (make-language-level-tester settings namespace)
|
||||
(lambda (source-list result-list completed-list)
|
||||
(reconstruct:set-render-settings! settings)
|
||||
(test-sequence source-list result-list completed-list namespace)))
|
||||
|
||||
(define test-beginner-sequence
|
||||
(make-language-level-tester fake-beginner-render-settings beginner-namespace))
|
||||
|
||||
(define test-beginner-wla-sequence
|
||||
(make-language-level-tester fake-beginner-wla-render-settings beginner-wla-namespace))
|
||||
|
||||
(define test-intermediate-sequence
|
||||
(make-language-level-tester fake-intermediate-render-settings intermediate-namespace))
|
||||
|
||||
(map syntax-object->datum
|
||||
(parameterize ([current-namespace beginner-namespace])
|
||||
(map expand (string->stx-list "(list a 3 4)"))))
|
||||
|
||||
;;;;;;;;;;;;;
|
||||
;;
|
||||
;; mz tests
|
||||
;;
|
||||
;;;;;;;;;;;;;
|
||||
|
||||
(test-mz-sequence "(for-each (lambda (x) x) '(1 2 3))"
|
||||
`(((,highlight-placeholder) ((for-each (lambda (x) x) `(1 2 3))))
|
||||
(((... ,highlight-placeholder ...)) (1))
|
||||
((...) ())
|
||||
(((... ,highlight-placeholder ...)) (2))
|
||||
((...) ())
|
||||
(((... ,highlight-placeholder ...)) (3))
|
||||
((...) ())
|
||||
((,highlight-placeholder) ((void)))))
|
||||
|
||||
(test-mz-sequence "(+ 3 4)"
|
||||
`(((,highlight-placeholder) ((+ 3 4)))
|
||||
((,highlight-placeholder) (7))))
|
||||
|
||||
(test-mz-sequence "((lambda (x) (+ x 3)) 4)"
|
||||
`(((,highlight-placeholder) (((lambda (x) (+ x 3)) 4)))
|
||||
((,highlight-placeholder) ((+ 4 3)))
|
||||
((,highlight-placeholder) ((+ 4 3)))
|
||||
((,highlight-placeholder) (7))))
|
||||
|
||||
(test-mz-sequence "(if 3 4 5)"
|
||||
`(((,highlight-placeholder) ((if 3 4 5)))
|
||||
((,highlight-placeholder) (4))))
|
||||
|
||||
(test-beginner-sequence "(if (if true false true) false true)"
|
||||
`((((if ,highlight-placeholder false true)) ((if true false true)))
|
||||
(((if ,highlight-placeholder false true)) (false))
|
||||
((,highlight-placeholder) ((if false false true)))
|
||||
((,highlight-placeholder) (true)))
|
||||
`(true))
|
||||
|
||||
(test-mz-sequence "((lambda (x) x) 3)"
|
||||
`(((,highlight-placeholder) (((lambda (x) x) 3)))
|
||||
((,highlight-placeholder) (3))))
|
||||
|
||||
; 'begin' not yet supported by reconstruct
|
||||
;(test-mz-sequence "((lambda (x) x) (begin (+ 3 4) (+ 4 5)"))
|
||||
; `((((begin ,highlight-placeholder (+ 4 5))) ((+ 3 4)))
|
||||
; (((begin ,highlight-placeholder (+ 4 5))) (7))
|
||||
; ((,highlight-placeholder) ((begin 7 (+ 4 5))))
|
||||
; ((,highlight-placeholder) ((+ 4 5)))
|
||||
; ((,highlight-placeholder) ((+ 4 5)))
|
||||
; ((,highlight-placeholder) (9))))
|
||||
|
||||
(test-mz-sequence "((lambda (a) (lambda (b) (+ a b))) 14)"
|
||||
`(((,highlight-placeholder) (((lambda (a) (lambda (b) (+ a b))) 14)))
|
||||
((,highlight-placeholder) ((lambda (b) (+ 14 b))))))
|
||||
|
||||
(test-mz-sequence "((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)"
|
||||
`(((,highlight-placeholder) (((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)))
|
||||
((,highlight-placeholder) ((+ 5 6)))
|
||||
((,highlight-placeholder) ((+ 5 6)))
|
||||
((,highlight-placeholder) (11))))
|
||||
|
||||
; reconstruct does not handle one-armed if's:
|
||||
;(test-mz-sequence "(if 3 4)"
|
||||
; `(((,highlight-placeholder) ((if 3 4)))
|
||||
; ((,highlight-placeholder) (4))))
|
||||
|
||||
; reconstruct does not handle begin0
|
||||
|
||||
;(test-mz-sequence "(let ([a 3]) 4)"
|
||||
; `(((,highlight-placeholder) ((let-values ([(a) 3]) 4)) (,highlight-placeholder ,highlight-placeholder) ((define-values (a_0) 3) (begin 4)))
|
||||
; (((define a_0 3)))))
|
||||
;
|
||||
;(test-mz-sequence "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))"
|
||||
; `(((,highlight-placeholder) ((let-values ([(a) (+ 4 5)] [(b) (+ 9 20)]) (+ a b)))
|
||||
; (,highlight-placeholder ,highlight-placeholder ,highlight-placeholder)
|
||||
; ((define-values (a_0) (+ 4 5)) (define-values (b_1) (+ 9 20)) (begin (+ a_0 b_1))))
|
||||
; (((define-values (a_0) ,highlight-placeholder) (define-values (b_1) (+ 9 20)) (begin (+ a_0 b_1))) ((+ 4 5)))
|
||||
; (((define-values (a_0) ,highlight-placeholder) (define-values (b_1) (+ 9 20)) (begin (+ a_0 b_1))) (9))
|
||||
; (((define a_0 9) (define-values (b_1) ,highlight-placeholder) (begin (+ a_0 b_1))) ((+ 9 20)))
|
||||
; (((define a_0 9) (define-values (b_1) ,highlight-placeholder) (begin (+ a_0 b_1))) (29))
|
||||
; (((define a_0 9) (define b_1 29)))
|
||||
; (((+ ,highlight-placeholder b_1)) (a_0))
|
||||
; (((+ ,highlight-placeholder b_1)) (9))
|
||||
; (((+ 9 ,highlight-placeholder)) (b_1))
|
||||
; (((+ 9 ,highlight-placeholder)) (29))
|
||||
; ((,highlight-placeholder) ((+ 9 29)))
|
||||
; ((,highlight-placeholder) (38))))
|
||||
|
||||
;(test-mz-sequence "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))"
|
||||
; `((((,highlight-placeholder (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)))
|
||||
; (((,highlight-placeholder (call-with-current-continuation call-with-current-continuation))) ((lambda args ...)))
|
||||
; ((((lambda args ...) ,highlight-placeholder)) ((call-with-current-continuation call-with-current-continuation)))
|
||||
; ((((lambda args ...) ,highlight-placeholder)) ((lambda args ...)))))
|
||||
|
||||
;(test-mz-sequence '(begin (define g 3) g)
|
||||
; `(((,highlight-placeholder) (g))
|
||||
; ((,highlight-placeholder) 3)))
|
||||
|
||||
;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x))))
|
||||
|
||||
(test-beginner-sequence "(define a (+ 3 4))"
|
||||
`((((define a ,highlight-placeholder)) ((+ 3 4)))
|
||||
(((define a ,highlight-placeholder)) (7)))
|
||||
`((define a 7)))
|
||||
|
||||
(test-beginner-sequence "(+ 4 129)"
|
||||
`(((,highlight-placeholder) ((+ 4 129)))
|
||||
((,highlight-placeholder) (133)))
|
||||
`(133))
|
||||
|
||||
(test-beginner-sequence "(if true 3 4)"
|
||||
`(((,highlight-placeholder) ((if true 3 4)))
|
||||
((,highlight-placeholder) (3)))
|
||||
`(3))
|
||||
|
||||
;;;;;;;;;;;;;
|
||||
;;
|
||||
;; COND
|
||||
;;
|
||||
;;;;;;;;;;;;;
|
||||
|
||||
(parameterize ([current-namespace beginner-namespace])
|
||||
(let* ([stx (expand (car (string->stx-list "(cond [else 3])")))]
|
||||
[stx-source (syntax-source stx)]
|
||||
[stx-posn (syntax-position stx)])
|
||||
(printf "expanded: ~a\n" (syntax-object->datum stx))
|
||||
(syntax-case stx (if begin #%datum)
|
||||
[(if dc dc2 stx2)
|
||||
(printf "stepper-else: ~a\n" (stepper-syntax-property stx 'stepper-else))
|
||||
]
|
||||
[stx
|
||||
(printf "outer thing has wrong shape: ~a\n" (syntax-object->datum (syntax stx)))])))
|
||||
|
||||
(test-beginner-sequence "(cond [false 4] [false 5] [true 3])"
|
||||
`(((,highlight-placeholder) ((cond (false 4) (false 5) (true 3))))
|
||||
((,highlight-placeholder) ((cond (false 5) (true 3))))
|
||||
((,highlight-placeholder) ((cond (false 5) (true 3))))
|
||||
((,highlight-placeholder) ((cond (true 3))))
|
||||
((,highlight-placeholder) ((cond (true 3))))
|
||||
((,highlight-placeholder) (3)))
|
||||
`(3))
|
||||
|
||||
(test-beginner-sequence "(cond [false 4] [else 9])"
|
||||
`(((,highlight-placeholder) ((cond [false 4] [else 9])))
|
||||
((,highlight-placeholder) ((cond [else 9])))
|
||||
((,highlight-placeholder) ((cond [else 9])))
|
||||
((,highlight-placeholder) (9)))
|
||||
`(9))
|
||||
|
||||
(test-beginner-sequence "(cond [true 3] [else (and true true)])"
|
||||
`(((,highlight-placeholder) ((cond (true 3) (else (and true true)))))
|
||||
((,highlight-placeholder) (3)))
|
||||
`(3))
|
||||
|
||||
|
||||
; syntactic error: (test-beginner-sequence "(cond)")
|
||||
|
||||
(test-beginner-sequence "(cond [else 3])"
|
||||
`(((,highlight-placeholder) ((cond (else 3))))
|
||||
((,highlight-placeholder) (3)))
|
||||
`(3))
|
||||
|
||||
(test-beginner-sequence "(cond [else (cond [else 3])])"
|
||||
`(((,highlight-placeholder) ((cond (else (cond (else 3))))))
|
||||
((,highlight-placeholder) ((cond (else 3))))
|
||||
((,highlight-placeholder) ((cond (else 3))))
|
||||
((,highlight-placeholder) (3)))
|
||||
`(3))
|
||||
|
||||
; reconstruct can't handle begin
|
||||
;(test-mz-sequence "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])"
|
||||
; `(((,highlight-placeholder) ((cond (#f 3 4) (#t (+ 3 4) (+ 4 9)))))
|
||||
; ((,highlight-placeholder) ((cond (#t (+ 3 4) (+ 4 9)))))
|
||||
; ((,highlight-placeholder) ((cond (#t (+ 3 4) (+ 4 9)))))
|
||||
; ((,highlight-placeholder) (begin (+ 3 4) (+ 4 9)))
|
||||
; (((begin ,highlight-placeholder (+ 4 9))) ((+ 3 4)))
|
||||
; (((begin ,highlight-placeholder (+ 4 9))) (7))
|
||||
; ((,highlight-placeholder) ((begin 7 (+ 4 9))))
|
||||
; ((,highlight-placeholder) ((+ 4 9)))
|
||||
; ((,highlight-placeholder) ((+ 4 9)))
|
||||
; ((,highlight-placeholder) (13))))
|
||||
;
|
||||
|
||||
|
||||
(test-beginner-sequence "(cond [false 3] [else (cond [true 4])])"
|
||||
`(((,highlight-placeholder) ((cond (false 3) (else (cond (true 4))))))
|
||||
((,highlight-placeholder) ((cond (else (cond (true 4))))))
|
||||
((,highlight-placeholder) ((cond (else (cond (true 4))))))
|
||||
((,highlight-placeholder) ((cond (true 4))))
|
||||
((,highlight-placeholder) ((cond (true 4))))
|
||||
((,highlight-placeholder) (4)))
|
||||
`(4))
|
||||
|
||||
;;;;;;;;;;;;;
|
||||
;;
|
||||
;; OR / AND
|
||||
;;
|
||||
;;;;;;;;;;;;;
|
||||
|
||||
(test-beginner-sequence "(or false true false)"
|
||||
`(((,highlight-placeholder) ((or false true false)))
|
||||
((,highlight-placeholder) ((or true false)))
|
||||
((,highlight-placeholder) ((or true false)))
|
||||
((,highlight-placeholder) (true)))
|
||||
`(true))
|
||||
|
||||
(test-beginner-sequence "(and true false true)"
|
||||
`(((,highlight-placeholder) ((and true false true)))
|
||||
((,highlight-placeholder) ((and false true)))
|
||||
((,highlight-placeholder) ((and false true)))
|
||||
((,highlight-placeholder) (false)))
|
||||
`(false))
|
||||
|
||||
(parameterize ([current-namespace beginner-namespace])
|
||||
(map syntax-object->datum
|
||||
;(map expand
|
||||
(annotate-exprs (map expand (list '(define (a19 x) x) '(a19 4))) (lambda (x y z) 3))
|
||||
;)
|
||||
))
|
||||
|
||||
(parameterize ([current-namespace beginner-namespace])
|
||||
(map syntax-object->datum
|
||||
(map expand (map expand (map expand (list 'a19))))))
|
||||
|
||||
(test-beginner-sequence "(define (a2 x) x) (a2 4)"
|
||||
`(((,highlight-placeholder) ((a2 4)))
|
||||
((,highlight-placeholder) (4)))
|
||||
`((define (a2 x) x) 4))
|
||||
|
||||
(test-beginner-sequence "(define (a3 x) (if true x x)) (a3 false)"
|
||||
`(((,highlight-placeholder) ((a3 false)))
|
||||
((,highlight-placeholder) ((if true false false)))
|
||||
((,highlight-placeholder) ((if true false false)))
|
||||
((,highlight-placeholder) (false)))
|
||||
`((define (a3 x) (if true x x)) false))
|
||||
|
||||
(test-beginner-sequence "(define (b2 x) (and true x)) (b2 false)"
|
||||
`(((,highlight-placeholder) ((b2 false)))
|
||||
((,highlight-placeholder) ((and true false)))
|
||||
((,highlight-placeholder) ((and true false)))
|
||||
((,highlight-placeholder) (false)))
|
||||
`((define (b2 x) (and true x)) false))
|
||||
|
||||
(test-beginner-sequence "(define a1 true)(define (b1 x) (and a1 true x)) (b1 false)"
|
||||
`(((,highlight-placeholder) ((b1 false)))
|
||||
((,highlight-placeholder) ((and a1 true false)))
|
||||
(((and ,highlight-placeholder true false)) (a1))
|
||||
(((and ,highlight-placeholder true false)) (true))
|
||||
((,highlight-placeholder) ((and true true false)))
|
||||
((,highlight-placeholder) ((and true false)))
|
||||
((,highlight-placeholder) ((and true false)))
|
||||
((,highlight-placeholder) (false)))
|
||||
`((define a1 true) (define (b1 x) (and a1 true x)) false))
|
||||
|
||||
|
||||
(test-intermediate-sequence "(define a4 +) a4"
|
||||
`(((,highlight-placeholder) (a4))
|
||||
((,highlight-placeholder) (+)))
|
||||
`((define a4 +) +))
|
||||
|
||||
(test-intermediate-sequence "(define (f123 x) (+ x 13)) f123"
|
||||
`()
|
||||
`((define (f123 x) (+ x 13)) f123))
|
||||
|
||||
(test-beginner-sequence "(define (b x) (+ x 13)) (b 9)"
|
||||
`(((,highlight-placeholder) ((b 9)))
|
||||
((,highlight-placeholder) ((+ 9 13)))
|
||||
((,highlight-placeholder) ((+ 9 13)))
|
||||
((,highlight-placeholder) (22)))
|
||||
`((define (b x) (+ x 13)) 22))
|
||||
|
||||
(test-beginner-sequence "(define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2))"
|
||||
`(((,highlight-placeholder) ((mamba-rhythm (make-mamba 24 2))))
|
||||
((,highlight-placeholder) (24)))
|
||||
`((define-struct mamba (rhythm tempo)) 24))
|
||||
|
||||
(test-beginner-sequence "(define a5 (lambda (a5) (+ a5 13))) (a5 23)"
|
||||
`(((,highlight-placeholder) ((a5 23)))
|
||||
((,highlight-placeholder) ((+ 23 13)))
|
||||
((,highlight-placeholder) ((+ 23 13)))
|
||||
((,highlight-placeholder) (36)))
|
||||
`((define a5 (lambda (a5) (+ a5 13))) 36))
|
||||
|
||||
(test-beginner-sequence "(define c1 false) (define (d2 x) (or c1 false x)) (d2 false)"
|
||||
`(((,highlight-placeholder) ((d2 false)))
|
||||
((,highlight-placeholder) ((or c1 false false)))
|
||||
(((or ,highlight-placeholder false false)) (c1))
|
||||
(((or ,highlight-placeholder false false)) (false))
|
||||
((,highlight-placeholder) ((or false false false)))
|
||||
((,highlight-placeholder) ((or false false)))
|
||||
((,highlight-placeholder) ((or false false)))
|
||||
((,highlight-placeholder) (false)))
|
||||
`((define c1 false) (define (d2 x) (or c1 false x)) false))
|
||||
|
||||
(test-beginner-sequence "(define (silly-choice str)
|
||||
(string-append str (if false str str) str))
|
||||
(silly-choice \"family\")"
|
||||
`(((,highlight-placeholder) ((silly-choice "family")))
|
||||
((,highlight-placeholder) ((string-append "family" (if false "family" "family") "family")))
|
||||
(((string-append "family" ,highlight-placeholder "family")) ((if false "family" "family")))
|
||||
(((string-append "family" ,highlight-placeholder "family")) ("family"))
|
||||
((,highlight-placeholder) ((string-append "family" "family" "family")))
|
||||
((,highlight-placeholder) ("familyfamilyfamily")))
|
||||
'((define (silly-choice str) (string-append str (if false str str) str)) "familyfamilyfamily"))
|
||||
|
||||
(test-beginner-sequence "(define (f x) (+ (g x) 10)) (define (g x) (- x 22)) (f 13)"
|
||||
`(((,highlight-placeholder) ((f 13)))
|
||||
((,highlight-placeholder) ((+ (g 13) 10)))
|
||||
(((+ ,highlight-placeholder 10)) ((g 13)))
|
||||
(((+ ,highlight-placeholder 10)) ((- 13 22)))
|
||||
(((+ ,highlight-placeholder 10)) ((- 13 22)))
|
||||
(((+ ,highlight-placeholder 10)) (-9))
|
||||
((,highlight-placeholder) ((+ -9 10)))
|
||||
((,highlight-placeholder) (1)))
|
||||
`((define (f x) (+ (g x) 10)) (define (g x) (- x 22)) 1))
|
||||
|
||||
(test-beginner-sequence "(define (f2 x) (+ (g2 x) 10))"
|
||||
`()
|
||||
`((define (f2 x) (+ (g2 x) 10))))
|
||||
|
||||
(err/rt-test (test-beginner-sequence "(cons 1 2)" `() `()) exn:application:type?)
|
||||
|
||||
(test-beginner-sequence "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)"
|
||||
`(((,highlight-placeholder) ((list 1 2 3)))
|
||||
((,highlight-placeholder) ((cons 1 (cons 2 (cons 3 empty))))))
|
||||
`((cons 3 (cons 1 empty)) (cons 1 (cons 2 (cons 3 empty))) (define-struct aa (b)) (make-aa 3)))
|
||||
|
||||
(test-beginner-sequence "(define a11 4)"
|
||||
`()
|
||||
`((define a11 4)))
|
||||
|
||||
(test-mz-sequence "(map (lambda (x) x) (list 3 4 5))"
|
||||
`((((map (lambda (x) x) ,highlight-placeholder)) ((list 3 4 5)))
|
||||
(((map (lambda (x) x) ,highlight-placeholder)) (`( 3 4 5)))
|
||||
((,highlight-placeholder) ((map (lambda (x) x) `(3 4 5))))
|
||||
(((... ,highlight-placeholder ...)) (3))
|
||||
((...) ())
|
||||
(((... ,highlight-placeholder ...)) (4))
|
||||
((...) ())
|
||||
(((... ,highlight-placeholder ...)) (5))
|
||||
((...) ())
|
||||
((,highlight-placeholder) (`(3 4 5)))))
|
||||
|
||||
(test-beginner-wla-sequence "'(3 4 5)"
|
||||
`()
|
||||
`((list 3 4 5)))
|
||||
|
||||
; note: we currently punt on trying to unwind quasiquote.
|
||||
|
||||
(test-beginner-wla-sequence "`(3 4 ,(+ 4 5))"
|
||||
`((((cons 3 (cons 4 (cons ,highlight-placeholder empty)))) ((+ 4 5)))
|
||||
(((cons 3 (cons 4 (cons ,highlight-placeholder empty)))) (9))
|
||||
(((cons 3 (cons 4 ,highlight-placeholder))) ((cons 9 empty)))
|
||||
(((cons 3 (cons 4 ,highlight-placeholder))) ((list 9)))
|
||||
(((cons 3 ,highlight-placeholder)) ((cons 4 (list 9))))
|
||||
(((cons 3 ,highlight-placeholder)) ((list 4 9)))
|
||||
((,highlight-placeholder) ((cons 3 (list 4 9))))
|
||||
((,highlight-placeholder) ((list 3 4 9))))
|
||||
`((list 3 4 9)))
|
||||
|
||||
(test-beginner-wla-sequence "`(3 ,@(list (+ 3 4) 5) 6)"
|
||||
`((((cons 3 (append (list ,highlight-placeholder 5) (cons 6 empty)))) ((+ 3 4)))
|
||||
(((cons 3 (append (list ,highlight-placeholder 5) (cons 6 empty)))) (7))
|
||||
(((cons 3 (append (list 7 5) ,highlight-placeholder))) ((cons 6 empty)))
|
||||
(((cons 3 (append (list 7 5) ,highlight-placeholder))) ((list 6)))
|
||||
(((cons 3 ,highlight-placeholder)) ((append (list 7 5) (list 6))))
|
||||
(((cons 3 ,highlight-placeholder)) ((list 7 5 6)))
|
||||
((,highlight-placeholder) ((cons 3 (list 7 5 6))))
|
||||
((,highlight-placeholder) ((list 3 7 5 6))))
|
||||
`((list 3 7 5 6)))
|
||||
|
||||
(test-intermediate-sequence "(local () (+ 3 4))"
|
||||
`(((,highlight-placeholder) ((local () (+ 3 4))))
|
||||
((,highlight-placeholder) ((+ 3 4)))
|
||||
((,highlight-placeholder) ((+ 3 4)))
|
||||
((,highlight-placeholder) (7)))
|
||||
`(7))
|
||||
|
||||
(test-intermediate-sequence "(local ((define (a x) (+ x 9))) (a 6))"
|
||||
`((())))
|
||||
|
||||
(test-intermediate-sequence "(local ((define (a x) (+ x 13))) a)"
|
||||
`((())))
|
||||
(test-intermediate-sequence "(local ((define (a x) (+ x 9)) (define b a)) (b 1))")
|
||||
|
||||
|
||||
;;;;;;;;;;;;;
|
||||
;;
|
||||
;; TEACHPACK TESTS
|
||||
;;
|
||||
;;;;;;;;;;;;;
|
||||
|
||||
(require mred)
|
||||
|
||||
(define tp-namespace
|
||||
(let ([ns (current-namespace)]
|
||||
[mred-name ((current-module-name-resolver) 'mred #f #f)]
|
||||
[new-namespace (make-namespace 'empty)])
|
||||
(parameterize ([current-namespace new-namespace])
|
||||
(namespace-attach-module ns 'mzscheme)
|
||||
(namespace-attach-module ns mred-name)
|
||||
(namespace-require 'lang/htdp-beginner)
|
||||
(namespace-require 'htdp/guess)
|
||||
new-namespace)))
|
||||
|
||||
(reconstruct:set-render-settings! fake-beginner-render-settings)
|
||||
(test-sequence "(define (check-guess guess target) 'TooSmall) (guess-with-gui check-guess)"
|
||||
`(((,highlight-placeholder) ((guess-with-gui check-guess)))
|
||||
((,highlight-placeholder) (true)))
|
||||
`((define (check-guess guess target) 'toosmall) true)
|
||||
tp-namespace)
|
||||
|
||||
|
||||
|
||||
(report-errs)
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
(module tests-common mzscheme
|
||||
|
||||
(require stepper/private/annotate
|
||||
mzlib/contract
|
||||
stepper/private/shared)
|
||||
|
||||
(provide/contract (reset-namespaces (-> void?))
|
||||
(annotate-exprs (-> (listof syntax?) break-contract (listof syntax?)))
|
||||
(string->stx-list (-> string? (listof syntax?))))
|
||||
|
||||
(provide mz-namespace
|
||||
beginner-namespace
|
||||
beginner-wla-namespace
|
||||
intermediate-namespace
|
||||
intermediate/lambda-namespace)
|
||||
|
||||
; : ((listof syntax?) (recon-result recon-result -> (void)) -> (listof syntax)
|
||||
(define (annotate-exprs stx-list break)
|
||||
(let loop ([env (make-initial-env-package)] [stx-list stx-list])
|
||||
(if (null? stx-list)
|
||||
null
|
||||
(let*-values ([(annotated new-env)
|
||||
(annotate (car stx-list) env break 'foot-wrap)])
|
||||
(cons annotated (loop new-env (cdr stx-list)))))))
|
||||
|
||||
; : (string -> (listof syntax)
|
||||
(define (string->stx-list stx)
|
||||
(let ([port (open-input-string stx)])
|
||||
(let loop ([first-stx (read-syntax 'test-program port)])
|
||||
(if (eof-object? first-stx)
|
||||
null
|
||||
(cons first-stx (loop (read-syntax 'test-program port)))))))
|
||||
|
||||
(define source-namespace (current-namespace))
|
||||
|
||||
(define mz-namespace #f)
|
||||
(define beginner-namespace #f)
|
||||
(define beginner-wla-namespace #f)
|
||||
(define intermediate-namespace #f)
|
||||
(define intermediate/lambda-namespace #f)
|
||||
|
||||
(define (new-namespace-from-spec spec)
|
||||
(let ([new-namespace (make-namespace 'empty)])
|
||||
(parameterize ([current-namespace new-namespace])
|
||||
(namespace-attach-module source-namespace 'mzscheme)
|
||||
(namespace-require spec))
|
||||
new-namespace))
|
||||
|
||||
(define (reset-namespaces)
|
||||
(set! mz-namespace (new-namespace-from-spec '(lib "plt-mzscheme.ss" "lang")))
|
||||
(set! beginner-namespace (new-namespace-from-spec '(lib "htdp-beginner.ss" "lang")))
|
||||
(set! beginner-wla-namespace (new-namespace-from-spec '(lib "htdp-beginner-abbr.ss" "lang")))
|
||||
(set! intermediate-namespace (new-namespace-from-spec '(lib "htdp-intermediate.ss" "lang")))
|
||||
(set! intermediate/lambda-namespace (new-namespace-from-spec '(lib "htdp-intermediate-lambda.ss" "lang")))))
|
||||
Loading…
Reference in New Issue
Block a user