From f68dda332487725ae161cf0424a3614bf68beecd Mon Sep 17 00:00:00 2001 From: John Clements Date: Sun, 4 Sep 2005 07:19:03 +0000 Subject: [PATCH] whoops... svn: r762 --- collects/tests/stepper/through-tests.ss | 1199 ----------------------- 1 file changed, 1199 deletions(-) diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 73262a3903..60e1eb5bc0 100644 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -20,1205 +20,6 @@ (iter (expand (car expr-list)) (stream-ify (cdr expr-list) iter))))) - (define (test-sequence-core namespace-spec teachpack-specs render-settings track-inferred-names? in-port expected-steps) - (let* ([current-error-display-handler (error-display-handler)]) - (let* ([all-steps - (append expected-steps - '((finished-stepping)))] - [receive-result - (lambda (result) - (if (null? all-steps) - (fprintf (current-error-port) "test-sequence: ran out of expected steps. Given result: ~v\n" result) - (begin - (unless (compare-steps result (car all-steps)) - (fprintf (current-error-port) "test-sequence: steps do not match.\ngiven: ~v\nexpected: ~v\n" result (car all-steps))) - - ; uncomment for testing: - #;(when (compare-steps result (car all-steps)) - (printf "test-sequence: steps match for expected result: ~v\n"(car all-steps))) - - (set! all-steps (cdr all-steps)))))] - [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 exprs iter))))]) - (let/ec escape - (parameterize ([error-escape-handler (lambda () (escape (void)))]) - (go program-expander receive-result render-settings track-inferred-names?))) - (error-display-handler current-error-display-handler)))) - - (define (test-sequence namespace-spec teachpack-specs render-settings track-inferred-names? exp-str expected-steps) - (let ([filename (build-path test-directory "stepper-test")]) - (call-with-output-file filename - (lambda (port) - (fprintf port "~a" exp-str)) - 'truncate) - (printf "testing string: ~v\n" exp-str) - (letrec ([port (open-input-file filename)]) - (test-sequence-core namespace-spec teachpack-specs render-settings track-inferred-names? port expected-steps)))) - - - (define (lang-level-test-sequence namespace-spec rs track-inferred-names?) - (lambda args - (apply test-sequence namespace-spec `() rs track-inferred-names? args))) - - (define (make-multi-level-test-sequence level-fns) - (lambda args - (for-each (lambda (fn) (apply fn args)) level-fns))) - - (define test-mz-sequence (lang-level-test-sequence 'mzscheme fake-mz-render-settings #f)) - (define test-beginner-sequence (lang-level-test-sequence `(lib "htdp-beginner.ss" "lang") fake-beginner-render-settings #t)) - (define test-beginner-wla-sequence (lang-level-test-sequence `(lib "htdp-beginner-abbr.ss" "lang") fake-beginner-wla-render-settings #t)) - (define test-intermediate-sequence (lang-level-test-sequence `(lib "htdp-intermediate.ss" "lang") fake-intermediate-render-settings #t)) - (define test-intermediate/lambda-sequence (lang-level-test-sequence `(lib "htdp-intermediate-lambda.ss" "lang") - fake-intermediate/lambda-render-settings - #f)) - - (define test-upto-int/lam (make-multi-level-test-sequence (list test-beginner-sequence - test-beginner-wla-sequence - test-intermediate-sequence - test-intermediate/lambda-sequence))) - - (define test-upto-int (make-multi-level-test-sequence (list test-beginner-sequence - test-beginner-wla-sequence - test-intermediate-sequence))) - - (define test-bwla-to-int/lam (make-multi-level-test-sequence (list test-beginner-wla-sequence - test-intermediate-sequence - test-intermediate/lambda-sequence))) - - (define test-both-ints (make-multi-level-test-sequence (list test-intermediate-sequence - test-intermediate/lambda-sequence))) - - ; mutate these to values you want to examine in the repl: - (define bell-jar-specimen-1 #f) - (define bell-jar-specimen-2 #f) - - ;; so->d/finished : call (syntax-object->hilite-datum stx #t). For finished steps, - ;; we want to ignore the highlight but not the xml boxes (and other future stuff?) - (define (so->d/finished stx) - (syntax-object->hilite-datum stx #t)) - - ; (-> step-result? sexp? boolean?) - (define (compare-steps actual expected) - (match expected - [`(before-after ,before ,after) - (and (before-after-result? actual) - (andmap (lambda (fn expected) - (unless (list? (fn actual)) - (fprintf (current-error-port) "not a list: ~v\n" (syntax-object->hilite-datum (fn actual)))) - (noisy-equal? (map syntax-object->hilite-datum (fn actual)) expected)) - (list before-after-result-exp before-after-result-post-exp) - (list before after)))] - [`(before-after-waiting ,before ,after ,waiting) - (and (before-after-result? actual) - (and (noisy-equal? (map syntax-object->hilite-datum (before-after-result-after-exprs actual)) waiting) - (compare-steps actual `(before-after ,before ,after))))] - [`(before-after-finished ,finished-exprs . ,rest) - (and (before-after-result? actual) - (compare-finished (map so->d/finished (before-after-result-finished-exprs actual)) finished-exprs) - (compare-steps actual `(before-after ,@rest)))] - [`(before-after-finished-waiting ,finished-exprs . ,rest) - (and (before-after-result? actual) - (compare-finished (map so->d/finished (before-after-result-finished-exprs actual)) finished-exprs) - (compare-steps actual `(before-after-waiting ,@rest)))] - [`(finished ,finished-exprs) - (and (finished-result? actual) - (compare-finished (map so->d/finished (finished-result-finished-exprs actual)) finished-exprs))] - [`(error ,err-msg) - (and (error-result? actual) - (equal? err-msg (error-result-err-msg actual)))] - [`(before-error ,before ,err-msg) - (and (before-error-result? actual) - (and (noisy-equal? (map syntax-object->hilite-datum (before-error-result-exp actual)) before) - (equal? (before-error-result-err-msg actual) err-msg)))] - [`(finished-stepping) (finished-stepping? actual)] - [else - (begin (fprintf (current-error-port) "compare-steps: unexpected expected step type: ~v\n" expected) - #f)])) - - ; noisy-equal? : (any any . -> . boolean) - ; like equal?, but prints a noisy error message - (define (noisy-equal? a b) - (if (equal? a b) - #t - (begin (fprintf (current-error-port) "~e is not equal? to ~e\nhere's the diff: ~e\n" a b (sexp-diff a b)) - #f))) - - ; (-> (listof sexp) (listof sexp) boolean?) - (define (compare-finished finished-exps expected-exps) - (and - (>= (length finished-exps) (length expected-exps)) - (andmap (lambda (x y) (if (equal? x y) - #t - (begin (fprintf (current-error-port) "~e is not equal? to ~e\nhere's the diff: ~e\n" x y (sexp-diff x y)) - #f))) - (list-tail finished-exps (- (length finished-exps) (length expected-exps))) - expected-exps))) - - (define list-of-tests null) - - (define (add-test name thunk) - (when (assq name list-of-tests) - (error 'add-test "name ~v is already in the list of tests" name)) - (set! list-of-tests (append list-of-tests (list (list name thunk))))) - - (define-syntax (t stx) - (syntax-case stx () - [(_ name test) - (syntax/loc stx (add-test `name (lambda () test)))])) - - (define (run-all-tests) - (for-each (lambda (test-pair) - (printf "running test: ~v\n" (car test-pair)) - ((cadr test-pair))) - list-of-tests)) - - (define (run-test name) - (printf "running test: ~v\n" name) - ((cadr (assq name list-of-tests)))) - - (define (run-tests names) - (map run-test names)) - - (t mz1 - (test-mz-sequence "(for-each (lambda (x) x) '(1 2 3))" - `((before-after ((hilite (for-each (lambda (x) x) `(1 2 3)))) ((... (hilite 1) ...))) - (before-after ((hilite ...)) ((... (hilite 2) ...))) - (before-after ((hilite ...)) ((... (hilite 3) ...))) - (before-after ((hilite ...)) ((hilite (void)))) - (finished ((void)))))) - - (t mz-app - (test-mz-sequence "(+ 3 4)" - `((before-after ((hilite (+ 3 4))) ((hilite 7))) - (finished (7))))) - - (t mz-app2 - (test-mz-sequence "((lambda (x) (+ x 3)) 4)" - `((before-after ((hilite ((lambda (x) (+ x 3)) 4))) - ((hilite (+ 4 3)))) - (before-after ((hilite (+ 4 3))) - ((hilite 7))) - (finished (7))))) - - (t mz-if - (test-mz-sequence "(if 3 4 5)" - `((before-after ((hilite (if 3 4 5))) ((hilite 4))) - (finished (4))))) - - (t simple-if - (test-upto-int/lam "(if true false true)" - `((before-after ((hilite (if true false true))) - ((hilite false))) - (finished (false))))) - - (t if-bool - (test-upto-int/lam "(if (if true false true) false true)" - `((before-after ((if (hilite (if true false true)) false true)) - ((if (hilite false) false true))) - (before-after ((hilite (if false false true))) ((hilite true))) - (finished (true))))) - - (t direct-app - (test-mz-sequence "((lambda (x) x) 3)" - `((before-after ((hilite ((lambda (x) x) 3))) ((hilite 3))) - (finished (3))))) - - - ; (test-mz-sequence "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" -; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) -; ((begin (hilite 7) (+ 4 5)))) -; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) -; (before-after ((hilite (+ 4 5))) ((hilite 9))) -; (finished (9)))) - - (t curried - (test-mz-sequence "((lambda (a) (lambda (b) (+ a b))) 14)" - `((before-after ((hilite ((lambda (a) (lambda (b) (+ a b))) 14))) - ((hilite (lambda (b) (+ 14 b))))) - (finished ((lambda (b) (+ 14 b))))))) - - (t case-lambda - (test-mz-sequence "((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)" - `((before-after ((hilite ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6))) ((hilite (+ 5 6)))) - (before-after ((hilite (+ 5 6))) ((hilite 11))) - (finished (11))))) - - (t 2armed-if - (test-mz-sequence "(if 3 4)" - `((before-after ((hilite (if 3 4))) ((hilite 4))) - (finished (4))))) - - - ;(test-mz-sequence "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" - ; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) - ; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) - ; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) - ; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) - - ;(test-mz-sequence '(begin (define g 3) g) - ; `((before-after ((hilite ,h-p)) (g) - ; ((hilite ,h-p)) 3))) - - ;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) - - (t top-def - (test-upto-int/lam "(define a (+ 3 4))" - `((before-after ((define a (hilite (+ 3 4)))) ((define a (hilite 7)))) - (finished ((define a 7)))))) - - (t top-def-ref - (test-upto-int/lam "(define a 6) a" - `((before-after-finished ((define a 6)) - ((hilite a)) - ((hilite 6))) - (finished (6))))) - - (t app - (test-upto-int/lam "(+ 4 129)" - `((before-after ((hilite (+ 4 129))) ((hilite 133))) - (finished (133))))) - - (t if - (test-upto-int/lam "(if true 3 4)" - `((before-after ((hilite (if true 3 4))) ((hilite 3))) - (finished (3))))) - - (t top-app - (test-upto-int "(define (a3 x) (if true x x)) (a3 false)" - `((before-after-finished ((define (a3 x) (if true x x))) ((hilite (a3 false))) - ((hilite (if true false false)))) - (before-after ((hilite (if true false false))) ((hilite false))) - (finished (false))))) - - (t top-app/lam - (test-intermediate/lambda-sequence "(define (a3 x) (if true x x)) (a3 false)" - `((before-after-finished ((define (a3 x) (if true x x))) - (((hilite a3) false)) (((hilite (lambda (x) (if true x x))) false))) - (before-after ((hilite ((lambda (x) (if true x x)) false))) - ((hilite (if true false false)))) - (before-after ((hilite (if true false false))) ((hilite false))) - (finished (false))))) - - (t top-interref - (test-intermediate-sequence "(define (a12 x) (+ x 9)) (define b12 a12) (b12 12)" - `((before-after-finished ((define (a12 x) (+ x 9)) (define b12 a12)) - (((hilite b12) 12)) (((hilite a12) 12))) - (before-after ((hilite (a12 12))) ((hilite (+ 12 9)))) - (before-after ((hilite (+ 12 9))) ((hilite 21))) - (finished (21))))) - - - - ;;;;;;;;;;;; - ;; - ;; OR / AND - ;; - ;;;;;;;;;;;;;. - - - (t or1 - (test-upto-int/lam "(or false true false)" - `((before-after ((hilite (or false true false))) ((hilite true))) - (finished (true))))) - - (t and1 - (test-upto-int/lam "(and true false true)" - `((before-after ((hilite (and true false true))) ((hilite false))) - (finished (false))))) - - (t and2 - (test-upto-int/lam "(and true (if true true false))" - `((before-after ((and true (hilite (if true true false)))) ((and true (hilite true)))) - (before-after ((hilite (and true true))) ((hilite true))) - (finished (true))))) - - (t and3 - (test-upto-int "(define (b2 x) (and true x)) (b2 false)" - `((before-after-finished ((define (b2 x) (and true x))) ((hilite (b2 false))) ((hilite (and true false)))) - (before-after ((hilite (and true false))) ((hilite false))) - (finished (false))))) - - (t and3/lam - (test-intermediate/lambda-sequence "(define (b2 x) (and true x)) (b2 false)" - `((before-after-finished ((define (b2 x) (and true x))) - (((hilite b2) false)) - (((hilite (lambda (x) (and true x))) false))) - (before-after ((hilite ((lambda (x) (and true x)) false))) - ((hilite (and true false)))) - (before-after ((hilite (and true false))) ((hilite false))) - (finished (false))))) - - (t and4 - (test-upto-int "(define a1 true)(define (b1 x) (and a1 true x)) (b1 false)" - `((before-after-finished ((define a1 true) - (define (b1 x) (and a1 true x))) - ((hilite (b1 false))) - ((hilite (and a1 true false)))) - (before-after ((and (hilite a1) true false)) ((and (hilite true) true false))) - (before-after ((hilite (and true true false))) ((hilite false))) - (finished (false))))) - - - (t and4/lam - (test-intermediate/lambda-sequence "(define a1 true)(define (b1 x) (and a1 true x)) (b1 false)" - `((before-after-finished ((define a1 true) - (define (b1 x) (and a1 true x))) - (((hilite b1) false)) - (((hilite (lambda (x) (and a1 true x))) false))) - (before-after ((hilite ((lambda (x) (and a1 true x)) false))) ((hilite (and a1 true false)))) - (before-after ((and (hilite a1) true false)) ((and (hilite true) true false))) - (before-after ((hilite (and true true false))) ((hilite false))) - (finished (false))))) - - (t bad-and - (test-upto-int/lam "(and true 1)" - `((before-error ((hilite (and true 1))) "and: question result is not true or false: 1")))) - - ;;;;;;;;;;;;; - ;; - ;; COND - ;; - ;;;;;;;;;;;;; - - - (t cond1 - (test-upto-int/lam "(cond [false 4] [false 5] [true 3])" - `((before-after ((hilite (cond (false 4) (false 5) (true 3)))) - ((hilite (cond (false 5) (true 3))))) - (before-after ((hilite (cond (false 5) (true 3)))) ((hilite (cond (true 3))))) - (before-after ((hilite (cond (true 3)))) ((hilite 3))) - (finished (3))))) - - (t cond-else - (test-upto-int/lam "(cond [false 4] [else 9])" - `((before-after ((hilite (cond [false 4] [else 9]))) ((hilite (cond [else 9])))) - (before-after ((hilite (cond [else 9]))) ((hilite 9))) - (finished (9))))) - - (t cond-andelse - (test-upto-int/lam "(cond [true 3] [else (and true true)])" - `((before-after ((hilite (cond (true 3) (else (and true true))))) ((hilite 3))) - (finished (3))))) - - (t bad-cond - (test-upto-int/lam "(cond)" - `((error "cond: expected a question--answer clause after `cond', but nothing's there")))) - - (t just-else - (test-upto-int/lam "(cond [else 3])" - `((before-after ((hilite (cond (else 3)))) ((hilite 3))) - (finished (3))))) - - (t nested-cond - (test-upto-int/lam "(cond [else (cond [else 3])])" - `((before-after ((hilite (cond (else (cond (else 3)))))) ((hilite (cond (else 3))))) - (before-after ((hilite (cond (else 3)))) ((hilite 3))) - (finished (3))))) - - ; reconstruct can't handle 'begin' - ; (test-mz-sequence "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])" - ; `((before-after ((hilite (cond (#f 3 4) (#t (+ 3 4) (+ 4 9))))) -; ((hilite (cond (#t (+ 3 4) (+ 4 9)))))) -; (before-after ((hilite (cond (#t (+ 3 4) (+ 4 9))))) ((hilite (begin (+ 3 4) (+ 4 9))))) -; (before-after ((begin (hilite (+ 3 4)) (+ 4 9))) -; ((begin (hilite 7) (+ 4 9)))) -; (before-after ((hilite (begin 7 (+ 4 9)))) ((hilite (+ 4 9)))) -; (before-after ((hilite (+ 4 9))) ((hilite 13))) -; (finished (13)))) - - (t nested-cond2 - (test-upto-int/lam "(cond [false 3] [else (cond [true 4])])" - `((before-after ((hilite (cond (false 3) (else (cond (true 4)))))) - ((hilite (cond (else (cond (true 4))))))) - (before-after ((hilite (cond (else (cond (true 4)))))) ((hilite (cond (true 4))))) - (before-after ((hilite (cond (true 4)))) ((hilite 4))) - (finished (4))))) - - (t top-ref - (test-intermediate-sequence "(define a4 +) a4" - `((before-after ((hilite a4)) ((hilite +))) - (finished (+))))) - - (t top-ref2 - (test-intermediate-sequence "(define (f123 x) (+ x 13)) f123" - `((finished ((define (f123 x) (+ x 13)) - f123))))) - - (t define-struct - (test-upto-int/lam "(define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2))" - `((before-after-finished ((define-struct mamba (rhythm tempo))) - ((hilite (mamba-rhythm (make-mamba 24 2)))) ((hilite 24))) - (finished (24))))) - - (t lam-def - (test-upto-int "(define a5 (lambda (a5) (+ a5 13))) (a5 23)" - `((before-after-finished ((define a5 (lambda (a5) (+ a5 13)))) ((hilite (a5 23))) ((hilite (+ 23 13)))) - (before-after ((hilite (+ 23 13))) ((hilite 36))) - (finished (36))))) - - (t lam-def/lam - (test-intermediate/lambda-sequence "(define a5 (lambda (a5) (+ a5 13))) (a5 23)" - `((before-after-finished ((define a5 (lambda (a5) (+ a5 13)))) - (((hilite a5) 23)) - (((hilite (lambda (a5) (+ a5 13))) 23))) - (before-after ((hilite ((lambda (a5) (+ a5 13)) 23))) - ((hilite (+ 23 13)))) - (before-after ((hilite (+ 23 13))) ((hilite 36))) - (finished (36))))) - - (t lam-let - (test-intermediate-sequence "(let ([a (lambda (x) (+ x 5))]) (a 6))" - `((before-after ((hilite (let ([a (lambda (x) (+ x 5))]) (a 6)))) - ((hilite (define a_0 (lambda (x) (+ x 5)))) (hilite (a_0 6)))) - (before-after-finished ((define a_0 (lambda (x) (+ x 5)))) - ((hilite (a_0 6))) - ((hilite (+ 6 5)))) - (before-after ((hilite (+ 6 5))) - ((hilite 11))) - (finished (11))))) - - (t whocares - (test-upto-int "(define c1 false) (define (d2 x) (or c1 false x)) (d2 false)" - `((before-after-finished ((define c1 false) - (define (d2 x) (or c1 false x))) - ((hilite (d2 false))) - ((hilite (or c1 false false)))) - (before-after ((or (hilite c1) false false)) ((or (hilite false) false false))) - (before-after ((hilite (or false false false))) ((hilite false))) - (finished (false))))) - - (t whocares/lam - (test-intermediate/lambda-sequence "(define c1 false) (define (d2 x) (or c1 false x)) (d2 false)" - `((before-after-finished ((define c1 false) - (define (d2 x) (or c1 false x))) - (((hilite d2) false)) (((hilite (lambda (x) (or c1 false x))) false))) - (before-after ((hilite ((lambda (x) (or c1 false x)) false))) - ((hilite (or c1 false false)))) - (before-after ((or (hilite c1) false false)) ((or (hilite false) false false))) - (before-after ((hilite (or false false false))) ((hilite false))) - (finished (false))))) - - - (t forward-ref - (test-upto-int "(define (f x) (+ (g x) 10)) (define (g x) (- x 22)) (f 13)" - `((before-after-finished ((define (f x) (+ (g x) 10)) (define (g x) (- x 22))) - ((hilite (f 13))) - ((hilite (+ (g 13) 10)))) - (before-after ((+ (hilite (g 13)) 10)) ((+ (hilite (- 13 22)) 10))) - (before-after ((+ (hilite (- 13 22)) 10)) ((+ (hilite -9) 10))) - (before-after ((hilite (+ -9 10))) ((hilite 1))) - (finished (1))))) - - (t forward-ref/lam - (test-intermediate/lambda-sequence "(define (f x) (+ (g x) 10)) (define (g x) (- x 22)) (f 13)" - `((before-after-finished ((define (f x) (+ (g x) 10)) (define (g x) (- x 22))) - (((hilite f) 13)) - (((hilite (lambda (x) (+ (g x) 10))) 13))) - (before-after ((hilite ((lambda (x) (+ (g x) 10)) 13))) - ((hilite (+ (g 13) 10)))) - (before-after ((+ ((hilite g) 13) 10)) ((+ ((hilite (lambda (x) (- x 22))) 13) 10))) - (before-after ((+ (hilite ((lambda (x) (- x 22)) 13)) 10)) ((+ (hilite (- 13 22)) 10))) - (before-after ((+ (hilite (- 13 22)) 10)) ((+ (hilite -9) 10))) - (before-after ((hilite (+ -9 10))) ((hilite 1))) - (finished (1))))) - - - (t bad-cons - (test-upto-int/lam "(cons 1 2)" - `((before-error ((hilite (cons 1 2))) "cons: second argument must be of type , given 1 and 2")))) - - (t prims - (test-beginner-sequence "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" - `((before-after-finished ((cons 3 (cons 1 empty))) - ((hilite (list 1 2 3))) - ((hilite (cons 1 (cons 2 (cons 3 empty)))))) - (finished ((cons 1 (cons 2 (cons 3 empty))) (define-struct aa (b)) (make-aa 3)))))) - - (t prims/non-beginner - (test-bwla-to-int/lam "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" - `((before-after ((cons 3 (hilite (cons 1 empty)))) ((cons 3 (hilite (list 1))))) - (before-after ((hilite (cons 3 (list 1)))) ((hilite (list 3 1)))) - (finished ((list 3 1) (list 1 2 3) (define-struct aa (b)) (make-aa 3)))))) - - - (t map - (test-mz-sequence "(map (lambda (x) x) (list 3 4 5))" - `((before-after ((map (lambda (x) x) (hilite (list 3 4 5)))) - ((map (lambda (x) x) (hilite `( 3 4 5))))) - (before-after ((hilite (map (lambda (x) x) `(3 4 5)))) - ((... (hilite 3) ...))) - (before-after ((hilite ...)) - ((... (hilite 4) ...))) - (before-after ((hilite ...)) - ((... (hilite 5) ...))) - (before-after ((hilite ...)) ((hilite `(3 4 5)))) - (finished (`(3 4 5)))))) - - (t quoted-list - (test-beginner-wla-sequence "'(3 4 5)" - `((finished ((list 3 4 5)))))) - - - ;;;;;;;;;;;;; - ;; - ;; QUASIQUOTE - ;; - ;;;;;;;;;;;;;. - - ; note: we currently punt on trying to unwind quasiquote. - - (t qq1 - (test-beginner-wla-sequence "`(3 4 ,(+ 4 5))" - `((before-after ((cons 3 (cons 4 (cons (hilite (+ 4 5)) empty)))) - ((cons 3 (cons 4 (cons (hilite 9) empty))))) - (before-after ((cons 3 (cons 4 (hilite (cons 9 empty))))) - ((cons 3 (cons 4 (hilite (list 9)))))) - (before-after ((cons 3 (hilite (cons 4 (list 9))))) - ((cons 3 (hilite (list 4 9))))) - (before-after ((hilite (cons 3 (list 4 9)))) ((hilite (list 3 4 9)))) - (finished ((list 3 4 9)))))) - - (t qq-splice - (test-beginner-wla-sequence "`(3 ,@(list (+ 3 4) 5) 6)" - `((before-after ((cons 3 (append (list (hilite (+ 3 4)) 5) (cons 6 empty)))) ((cons 3 (append (list (hilite 7) 5) (cons 6 empty))))) - (before-after ((cons 3 (append (list 7 5) (hilite (cons 6 empty))))) ((cons 3 (append (list 7 5) (list 6))))) - (before-after ((cons 3 (hilite (append (list 7 5) (list 6))))) ((cons 3 (hilite (list 7 5 6))))) - (before-after ((hilite (cons 3 (list 7 5 6)))) ((hilite (list 3 7 5 6)))) - (finished ((list 3 7 5 6)))))) - - ;;;;;;;;;;;;; - ;; - ;; LET - ;; - ;;;;;;;;;;;;; - - (t let1 (test-both-ints "(let ([a 3]) 4)" - `((before-after ((hilite (let ([a 3]) 4))) ((hilite (define a_0 3)) (hilite 4))) - (finished ((define a_0 3) 4))))) - - (t let2 - (test-both-ints "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))" - `((before-after ((hilite (let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b)))) - ((hilite (define a_0 (+ 4 5))) (hilite (define b_0 (+ 9 20))) (hilite (+ a_0 b_0)))) - (before-after-waiting ((define a_0 (hilite (+ 4 5)))) ((define a_0 (hilite 9))) - ((define b_0 (+ 9 20)) - (+ a_0 b_0))) - (before-after-finished-waiting ((define a_0 9)) - ((define b_0 (hilite (+ 9 20)))) ((define b_0 (hilite 29))) - ((+ a_0 b_0))) - (before-after-finished ((define b_0 29)) - ((+ (hilite a_0) b_0)) ((+ (hilite 9) b_0))) - (before-after ((+ 9 (hilite b_0))) ((+ 9 (hilite 29)))) - (before-after ((hilite (+ 9 29))) ((hilite 38))) - (finished (38))))) - - (t let-scoping1 - (test-intermediate-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" - `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) - (before-after-finished ((define a_0 3)) ((hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) ((hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) - (before-after-finished ((define a_1 (lambda (x) (+ a_0 x)))) - ((hilite (a_1 4))) - ((hilite (+ a_0 4)))) - (before-after ((+ (hilite a_0) 4)) ((+ (hilite 3) 4))) - (before-after ((hilite (+ 3 4))) ((hilite 7))) - (finished (7))))) - - (t let-scoping2 - (test-intermediate/lambda-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" - `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) - ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) - (before-after-finished ((define a_0 3)) ((hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) - ((hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) - (before-after-finished ((define a_1 (lambda (x) (+ a_0 x)))) - (((hilite a_1) 4)) (((hilite (lambda (x) (+ a_0 x))) 4))) - (before-after ((hilite ((lambda (x) (+ a_0 x)) 4))) ((hilite (+ a_0 4)))) - (before-after ((+ (hilite a_0) 4)) ((+ (hilite 3) 4))) - (before-after ((hilite (+ 3 4))) ((hilite 7))) - (finished (7))))) - - (t let-scoping3 - (test-intermediate-sequence "(define a12 3) (define c12 19) (let ([a12 13] [b12 a12]) (+ b12 a12 c12))" - `((before-after-finished ((define a12 3) (define c12 19)) - ((hilite (let ([a12 13] [b12 a12]) (+ b12 a12 c12)))) - ((hilite (define a12_0 13)) (hilite (define b12_0 a12)) (hilite (+ b12_0 a12_0 c12)))) - (before-after-finished-waiting ((define a12_0 13)) - ((define b12_0 (hilite a12))) ((define b12_0 (hilite 3))) - ( (+ b12_0 a12_0 c12))) - (before-after-finished ((define b12_0 3)) - ((+ (hilite b12_0) a12_0 c12)) ((+ (hilite 3) a12_0 c12))) - (before-after ((+ 3 (hilite a12_0) c12)) ((+ 3 (hilite 13) c12))) - (before-after ((+ 3 13 (hilite c12))) ((+ 3 13 (hilite 19)))) - (before-after ((hilite (+ 3 13 19))) ((hilite 35))) - (finished (35))))) - - (t let-lifting1 - (test-intermediate-sequence "(let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) - (before-after-finished-waiting ((define a_0 (lambda (x) (+ x 14)))) - ((define b_0 (hilite (+ 3 4)))) ((define b_0 (hilite 7))) - (9)) - (finished ((define b_0 7) 9))))) - - (t let-deriv - (test-intermediate-sequence "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - `((before-after-finished ((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp))) - ((define gprime (hilite (f cos)))) ((define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after ((define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - ((hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished ((define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))) (define gprime gp_0)))))) - - ;;;;;;;;;;;;; - ;; - ;; LET* - ;; - ;;;;;;;;;;;;; - - (t let*-scoping1 - (test-both-ints "(define a 3) (define c 19) (let* ([a 13] [b a]) (+ b a c))" - `((before-after-finished ((define a 3) (define c 19)) - ((hilite (let* ([a 13] [b a]) (+ b a c)))) - ((hilite (define a_0 13)) (hilite (let* ([b a_0]) (+ b a_0 c))))) - (before-after-finished ((define a_0 13)) - ((hilite (let* ([b a_0]) (+ b a_0 c)))) - ((hilite (define b_1 a_0)) (hilite (+ b_1 a_0 c)))) - (before-after-finished-waiting () - ((define b_1 (hilite a_0))) ((define b_1 (hilite 13))) - ((+ b_1 a_0 c))) - (before-after-finished ((define b_1 13)) - ((+ (hilite b_1) a_0 c)) ((+ (hilite 13) a_0 c))) - (before-after ((+ 13 (hilite a_0) c)) ((+ 13 (hilite 13) c))) - (before-after ((+ 13 13 (hilite c))) ((+ 13 13 (hilite 19)))) - (before-after ((hilite (+ 13 13 19))) ((hilite 45))) - (finished (45))))) - - (t let*-lifting1 - (test-intermediate-sequence "(let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (let* ([b (+ 3 4)]) 9)))) - (before-after-finished ((define a_0 (lambda (x) (+ x 14)))) - ((hilite (let* ([b (+ 3 4)]) 9))) - ((hilite (define b_1 (+ 3 4))) (hilite 9))) - (before-after-finished-waiting () - ((define b_1 (hilite (+ 3 4)))) ((define b_1 (hilite 7))) - (9)) - (finished ((define b_1 7) 9))))) - - (t let*-deriv - (test-intermediate-sequence "(define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - `((before-after-finished ((define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp))) - ((define gprime (hilite (f cos)))) ((define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after ((define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - ((hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished ((define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))) (define gprime gp_0)))))) - - (t let/let* - (test-both-ints "(let* ([a 9]) (let ([b 6]) a))" - `((before-after ((hilite (let* ([a 9]) (let ([b 6]) a)))) ((hilite (define a_0 9)) (hilite (let ([b 6]) a_0)))) - (before-after-finished ((define a_0 9)) ((hilite (let ([b 6]) a_0))) ((hilite (define b_1 6)) (hilite a_0))) - (before-after-finished ((define b_1 6)) ((hilite a_0)) ((hilite 9))) - (finished (9))))) - - ;;;;;;;;;;;;; - ;; - ;; LETREC - ;; - ;;;;;;;;;;;;; - - (t letrec1 - (test-intermediate-sequence "(define a 3) (define c 19) (letrec ([a 13] [b a]) (+ b a c))" - `((before-after-finished ((define a 3) (define c 19)) - ((hilite (letrec ([a 13] [b a]) (+ b a c)))) - ((hilite (define a_0 13)) (hilite (define b_0 a_0)) (hilite (+ b_0 a_0 c)))) - (before-after-finished-waiting ((define a_0 13)) - ((define b_0 (hilite a_0))) ((define b_0 (hilite 13))) - ( (+ b_0 a_0 c))) - (before-after-finished ((define b_0 13)) - ((+ (hilite b_0) a_0 c)) ((+ (hilite 13) a_0 c))) - (before-after ((+ 13 (hilite a_0) c)) ((+ 13 (hilite 13) c))) - (before-after ((+ 13 13 (hilite c))) ((+ 13 13 (hilite 19)))) - (before-after ((hilite (+ 13 13 19))) ((hilite 45))) - (finished (45))))) - - (t letrec2 - (test-intermediate-sequence "(letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) - (before-after-finished-waiting ((define a_0 (lambda (x) (+ x 14)))) - ((define b_0 (hilite (+ 3 4)))) ((define b_0 (hilite 7))) - (9)) - (finished ((define b_0 7) 9))))) - - (t letrec3 - (test-intermediate-sequence "(define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - `((before-after-finished ((define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp))) - ((define gprime (hilite (f cos)))) - ((define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after ((define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - ((hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished ((define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))) (define gprime gp_0)))))) - ;;;;;;;;;;;;; - ;; - ;; RECUR - ;; - ;;;;;;;;;;;;; - - ;; N.B. : we cheat here. In particular, the rhs of the double-break expression should highlight the whole application, and not - ;; just the applied loop identifier. This is hard to fix because we have an application which is initially hidden, but then later - ;; not hidden. Fixing this involves parameterizing the unwind by what kind of break it was. Yuck! So we just fudge the test case. - - (t recur - (test-intermediate-sequence "(define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) (countdown 2)" - `((before-after-finished ((define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1)))))) - ((hilite (countdown 2))) - ((hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1))))))) - (before-after ((hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))) - ((hilite (define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) ((hilite loop_0) 2))) - (before-after-finished ((define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) - ((hilite (loop_0 2))) - ((hilite (if (= 2 0) 13 (loop_0 (- 2 1)))))) - (before-after ((if (hilite (= 2 0)) 13 (loop_0 (- 2 1)))) ((if (hilite false) 13 (loop_0 (- 2 1))))) - (before-after ((hilite (if false 13 (loop_0 (- 2 1))))) ((hilite (loop_0 (- 2 1))))) - (before-after ((loop_0 (hilite (- 2 1)))) ((loop_0 (hilite 1)))) - (before-after ((hilite (loop_0 1))) ((hilite (if (= 1 0) 13 (loop_0 (- 1 1)))))) - (before-after ((if (hilite (= 1 0)) 13 (loop_0 (- 1 1)))) ((if (hilite false) 13 (loop_0 (- 1 1))))) - (before-after ((hilite (if false 13 (loop_0 (- 1 1))))) ((hilite (loop_0 (- 1 1))))) - (before-after ((loop_0 (hilite (- 1 1)))) ((loop_0 (hilite 0)))) - (before-after ((hilite (loop_0 0))) ((hilite (if (= 0 0) 13 (loop_0 (- 0 1)))))) - (before-after ((if (hilite (= 0 0)) 13 (loop_0 (- 0 1)))) ((if (hilite true) 13 (loop_0 (- 0 1))))) - (before-after ((hilite (if true 13 (loop_0 (- 0 1))))) ((hilite 13))) - (finished (13))))) - - ;;;;;;;;;;;;; - ;; - ;; LOCAL - ;; - ;;;;;;;;;;;;; - - - (t empty-local - (test-both-ints "(local () (+ 3 4))" - `((before-after ((hilite (local () (+ 3 4)))) ((hilite (+ 3 4)))) - (before-after ((hilite (+ 3 4))) ((hilite 7))) - (finished (7))))) - - (t local1 - (test-both-ints "(local ((define a 3) (define b 8)) 4)" - `((before-after ((hilite (local ((define a 3) (define b 8)) 4))) - ((hilite (define a_0 3)) (hilite (define b_0 8)) (hilite 4))) - (finished ((define a_0 3) (define b_0 8) 4))))) - - (t local2 - (test-intermediate-sequence "(local ((define (a x) (+ x 9))) (a 6))" - `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) - (before-after-finished ((define (a_0 x) (+ x 9))) - ((hilite (a_0 6))) ((hilite (+ 6 9)))) - (before-after ((hilite (+ 6 9))) ((hilite 15))) - (finished (15))))) - - (t local3 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9))) (a 6))" - `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) - (before-after-finished ((define (a_0 x) (+ x 9))) - (((hilite a_0) 6)) (((hilite (lambda (x) (+ x 9))) 6))) - (before-after ((hilite ((lambda (x) (+ x 9)) 6))) ((hilite (+ 6 9)))) - (before-after ((hilite (+ 6 9))) ((hilite 15))) - (finished (15))))) - - (t local4 - (test-intermediate-sequence "(local ((define (a x) (+ x 13))) a)" - `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) - (finished ((define (a_0 x) (+ x 13)) a_0))))) - - (t local5 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 13))) a)" - `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) - (before-after ((hilite a_0)) ((hilite (lambda (x) (+ x 13))))) - (finished ((define (a_0 x) (+ x 13)) (lambda (x) (+ x 13))))))) - - (t local-interref1 - (test-intermediate-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" - `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) - (before-after-finished-waiting ((define (a_0 x) (+ x 9)) (define b_0 a_0)) - ((define p_0 (hilite (+ 3 4)))) ((define p_0 (hilite 7))) ((b_0 1))) - (before-after-finished ((define p_0 7)) - (((hilite b_0) 1)) (((hilite a_0) 1))) - (before-after ((hilite (a_0 1))) ((hilite (+ 1 9)))) - (before-after ((hilite (+ 1 9))) ((hilite 10))) - (finished (10))))) - - (t local-interref2 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" - `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) - (before-after-finished-waiting ((define (a_0 x) (+ x 9))) - ((define b_0 (hilite a_0))) ((define b_0 (hilite (lambda (x) (+ x 9))))) ((define p_0 (+ 3 4)) (b_0 1))) - (before-after-finished-waiting ((define b_0 (lambda (x) (+ x 9)))) - ((define p_0 (hilite (+ 3 4)))) ((define p_0 (hilite 7))) ((b_0 1))) - (before-after-finished ((define p_0 7)) - (((hilite b_0) 1)) (((hilite (lambda (x) (+ x 9))) 1))) - (before-after ((hilite ((lambda (x) (+ x 9)) 1))) ((hilite (+ 1 9)))) - (before-after ((hilite (+ 1 9))) ((hilite 10))) - (finished (10))))) - - (t local-gprime - (test-intermediate-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" - `((before-after-finished ((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) - ((define gprime (hilite (f12 cos)))) - ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) - (before-after ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) - ((hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) - (finished ((define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime gp_0)))))) - - (t local-gprime/lambda - (test-intermediate/lambda-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" - `((before-after-finished ((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) - ((define gprime ((hilite f12) cos))) - ((define gprime ((hilite (lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) cos)))) - (before-after ((define gprime (hilite ((lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) cos)))) - ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) - (before-after ((define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) - ((hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) - (before-after-finished ((define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) - ((define gprime (hilite gp_0))) ((define gprime (hilite (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))))) - (finished ((define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))))))) - - ; test generativity... that is, multiple evaluations of a local get different lifted names: - - (t local-generative - (test-intermediate-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" - `((before-after-finished ((define (a13 b13 c13) (b13 c13)) - (define (f9 x) (local ((define (maker dc) x)) maker))) - ((define m1 (hilite (f9 3)))) ((define m1 (hilite (local ((define (maker dc) 3)) maker))))) - (before-after ((define m1 (hilite (local ((define (maker dc) 3)) maker)))) - ((hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) - (before-after-finished ((define (maker_0 dc) 3) (define m1 maker_0)) - ((a13 (hilite (f9 4)) 1)) ((a13 (hilite (local ((define (maker dc) 4)) maker)) 1))) - (before-after ((a13 (hilite (local ((define (maker dc) 4)) maker)) 1)) - ((hilite (define (maker_1 dc) 4)) (a13 (hilite maker_1) 1))) - (before-after-finished ((define (maker_1 dc) 4)) - ((hilite (a13 maker_1 1))) ((hilite (maker_1 1)))) - (before-after ((hilite (maker_1 1))) ((hilite 4))) - (finished (4))))) - - (t local-generative/lambda - (test-intermediate/lambda-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" - `((before-after-finished ((define (a13 b13 c13) (b13 c13)) - (define (f9 x) (local ((define (maker dc) x)) maker))) - ((define m1 ((hilite f9) 3))) ((define m1 ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 3)))) - (before-after ((define m1 (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 3)))) - ((define m1 (hilite (local ((define (maker dc) 3)) maker))))) - (before-after ((define m1 (hilite (local ((define (maker dc) 3)) maker)))) - ((hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) - (before-after-finished ((define (maker_0 dc) 3)) - ((define m1 (hilite maker_0))) ((define m1 (hilite (lambda (dc) 3))))) - (before-after-finished ((define m1 (lambda (dc) 3))) - (((hilite a13) (f9 4) 1)) (((hilite (lambda (b13 c13) (b13 c13))) (f9 4) 1))) - (before-after (((lambda (b13 c13) (b13 c13)) ((hilite f9) 4) 1)) - (((lambda (b13 c13) (b13 c13)) ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 4) 1))) - (before-after (((lambda (b13 c13) (b13 c13)) (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 4)) 1)) - (((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1))) - (before-after (((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1)) - ((hilite (define (maker_1 dc) 4)) ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1))) - (before-after-finished ((define (maker_1 dc) 4)) - (((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)) - (((lambda (b13 c13) (b13 c13)) (hilite (lambda (dc) 4)) 1))) - (before-after ((hilite ((lambda (b13 c13) (b13 c13)) (lambda (dc) 4) 1))) ((hilite ((lambda (dc) 4) 1)))) - (before-after ((hilite ((lambda (dc) 4) 1))) ((hilite 4))) - (finished (4))))) - - ;;;;;;;;;;;;; - ;; - ;; Reduction of Lambda in int/lambda - ;; - ;;;;;;;;;;;;; - - (t int/lam1 - (test-intermediate/lambda-sequence "(define f ((lambda (x) x) (lambda (x) x))) (f f)" - `((before-after ((define f (hilite ((lambda (x) x) (lambda (x) x))))) ((define f (hilite (lambda (x) x))))) - (before-after-finished ((define f (lambda (x) x))) - (((hilite f) f)) (((hilite (lambda (x) x)) f))) - (before-after (((lambda (x) x) (hilite f))) (((lambda (x) x) (hilite (lambda (x) x))))) - (before-after ((hilite ((lambda (x) x) (lambda (x) x)))) ((hilite (lambda (x) x)))) - (finished ((define f (lambda (x) x)) (lambda (x) x)))))) - - - (t int/lam2 - (test-intermediate/lambda-sequence "(define f (if false (lambda (x) x) (lambda (x) x))) (f f)" - `((before-after ((define f (hilite (if false (lambda (x) x) (lambda (x) x))))) - ((define f (hilite (lambda (x) x))))) - (before-after-finished ((define f (lambda (x) x))) - (((hilite f) f)) (((hilite (lambda (x) x)) f))) - (before-after (((lambda (x) x) (hilite f))) (((lambda (x) x) (hilite (lambda (x) x))))) - (before-after ((hilite ((lambda (x) x) (lambda (x) x)))) ((hilite (lambda (x) x)))) - (finished ((define f (lambda (x) x)) (lambda (x) x)))))) - - - (t time - (test-intermediate-sequence "(time (+ 3 4))" - `((before-after ((hilite (+ 3 4))) - ((hilite 7))) - (finished (7))))) - - - ;;;;;;;;;;;;;;;; - ;; - ;; XML (uses MrEd) - ;; - ;;;;;;;;;;;;;;;; - - #;(t ddj-screenshot - (test-mz-sequence (define-syntax (xml stx) - (letrec ([process-xexpr - (lambda (xexpr) - (syntax-case xexpr (lmx lmx-splice) - [(lmx-splice unquoted) #`(unquote-splicing unquoted)] - [(lmx unquoted) #`(unquote unquoted)] - [(tag ([attr val] ...) . sub-xexprs) - (identifier? #`tag) - #`(tag ([attr val] ...) #,@(map process-xexpr (syntax->list #`sub-xexprs)))] - [(tag . sub-xexprs) - (identifier? #`tag) - #`(tag () #,@(map process-xexpr (syntax->list #`sub-xexprs)))] - [str - (string? (syntax-e #`str)) - xexpr]))]) - (syntax-case stx () - [(_ xexpr) #`(quasiquote #,(process-xexpr #`xexpr))]))) - (xml (article (header (author "John Clements") - (title (if (< 3 4) - (xml "No Title Available") - (get-title)))) - (text "More Sample Text"))) - '((before-after-finished ((define-syntax (xml stx) - (letrec ([process-xexpr - (lambda (xexpr) - (syntax-case xexpr (lmx lmx-splice) - [(lmx-splice unquoted) #`(unquote-splicing unquoted)] - [(lmx unquoted) #`(unquote unquoted)] - [(tag ([attr val] ...) . sub-xexprs) - (identifier? #`tag) - #`(tag ([attr val] ...) #,@(map process-xexpr (syntax->list #`sub-xexprs)))] - [(tag . sub-xexprs) - (identifier? #`tag) - #`(tag () #,@(map process-xexpr (syntax->list #`sub-xexprs)))] - [str - (string? (syntax-e #`str)) - xexpr]))]) - (syntax-case stx () - [(_ xexpr) #`(quasiquote #,(process-xexpr #`xexpr))])))) - ((xml )) - ((xml (a ([a "x"]) "ab" "hdo" "hon"))))))) - - #;(define (test-xml-sequence namespace-spec render-settings track-inferred-names? spec expected-steps) - (letrec ([port (open-input-text-editor (construct-text spec))]) - (test-sequence-core namespace-spec render-settings track-inferred-names? port expected-steps))) - - #;(define (construct-text spec) - (let ([new-text (instantiate text% ())]) - (for-each - (match-lambda - [`(xml-box ,@(xmlspec ...)) (send new-text insert (construct-xml-box xmlspec))] - [(? string? text) (send new-text insert text)]) - spec) - new-text)) - - #;(define (test-xml-beginner-sequence spec expected) - (test-xml-sequence `(lib "htdp-beginner.ss" "lang") - fake-beginner-render-settings - #t - spec - expected)) - - #;(t xml-box1 - (test-xml-beginner-sequence `((xml-box "3")) - `((finished ((xml-box-value (cons 'abba (cons empty (cons "3" empty))))))))) - - #;(t xml-box2 - (text-xml-beginnner-sequence `("(cdr (cdr " (xml-box "a b") "))") - `((before-after ((cdr (cdr (xml-box "a b")))))))) - - ; - ; ;;;;;;;;;;;;; - ; ;; - ; ;; TIME - ; ;; - ; ;;;;;;;;;;;;; - ; - ; (test-intermediate-sequence "(time (+ 3 4))" - ; `((before-after ((time (hilite ,h-p))) ((+ 3 4)) same (7)) - ; (before-after ((hilite ,h-p)) ((time 7)) same (7)) - ; (result (7)))) - - - ;(t filled-rect-image - ; (test-upto-int-lam "(image-width (filled-rect 10 10 'blue))" - ; `((before-after ((image-width (hilite (filled-rect 10 10 'blue)))) ((image-width (hilite ))))))) - ; add image test: (image-width (filled-rect 10 10 'blue)) - - ;;;;;;;;;;;;;; - ;; - ;; PRIM TESTS - ;; - ;;;;;;;;;;;;;; - - - - - ; ;;;;;;;;;;;;; - ; ;; - ; ;; TEACHPACK TESTS - ; ;; - ; ;;;;;;;;;;;;; - ; - - ; as you can see, many teachpack tests work only in mred: - #; (require (lib "mred.ss" "mred")) - - - (define test-teachpack-sequence (lambda (teachpack-specs expr-string expected-results) - ;(let ([new-custodian (make-custodian)]) - ; (parameterize ([current-custodian new-custodian]) - ; (parameterize ([current-eventspace (make-eventspace)]) - (test-sequence `(lib "htdp-beginner.ss" "lang") teachpack-specs fake-beginner-render-settings #t expr-string expected-results) - ;)) - ; (custodian-shutdown-all new-custodian)) - )) - - - ; uses set-render-settings! - ;(reconstruct:set-render-settings! fake-beginner-render-settings) - ;(test-sequence "(define (check-guess guess target) 'TooSmall) (guess-with-gui check-guess)" - ; `((before-after ((hilite ,h-p)) ((guess-with-gui check-guess))) - ; (((hilite ,h-p)) (true))) - ; `((define (check-guess guess target) 'toosmall) true) - ; tp-namespace) - - #;(t teachpack-drawing - (test-teachpack-sequence - `((lib "draw.ss" "htdp")) - "(define (draw-limb i) (cond - [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])) - (and (start 100 100) - (draw-limb 0))" - `((before-after-finished ((define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and (hilite (start 100 100)) (draw-limb 0))) - ((and (hilite true) (draw-limb 0)))) - (before-after ((and true (hilite (draw-limb 0)))) - ((and true (hilite (cond [(= 0 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) - (before-after ((and true (cond [(hilite (= 0 1)) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and true (cond [(hilite false) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - (before-after ((and true (hilite (cond [false (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - ((and true (hilite (cond [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) - (before-after ((and true (cond [(hilite (= 0 0)) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and true (cond [(hilite true) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - (before-after ((and true (hilite (cond [true (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - ((and true (hilite (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red))))) - (before-after ((and true (draw-solid-line (make-posn (hilite (+ 1 10)) 10) (make-posn 10 100) 'red))) - ((and true (draw-solid-line (make-posn (hilite 11) 10) (make-posn 10 100) 'red)))) - (before-after ((and true (hilite (draw-solid-line (make-posn 11 10) (make-posn 10 100) 'red)))) - ((and true (hilite true)))) - (before-after ((hilite (and true true))) - ((hilite true))) - (finished (true))))) - - #;(t teachpack-name-rendering - (test-teachpack-sequence - `((file "/Users/clements/plt/teachpack/htdp/draw.ss")) - "(start 300 300) (if true (get-key-event) 3)" - `((before-after ((hilite (start 300 300))) - ((hilite true))) - (before-after-finished (true) - ((hilite (if true (get-key-event) 3))) - ((hilite (get-key-event)))) - (before-after ((hilite (get-key-event))) - ((hilite false))) - (finished (false))))) - - #;(t teachpack-hop-names - (test-teachpack-sequence - `((file "/Users/clements/plt/teachpack/htdp/draw.ss")) - "(start 300 300) (define (a x y) (+ 3 4)) (if true (on-key-event a) 3)" - `((before-after ((hilite (start 300 300))) - ((hilite true))) - (before-after-finished (true (define (a x y) (+ 3 4))) - ((hilite (if true (on-key-event a) 3))) - ((hilite (on-key-event a)))) - (before-after ((hilite (on-key-event a))) - ((hilite true))) - (finished (true))))) - - #;(t teachpack-web-interaction - (test-teachpack-sequence - `((lib "servlet2.ss" "htdp")) -"(define (adder go) (inform (number->string (+ (single-query (make-number \"enter 10\")) (single-query (make-number \"enter 20\")))))) -(adder true)" -`((before-after-finished ((define (adder go) (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20"))))))) - ((hilite (adder true))) - ((hilite (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20")))))))) - (before-after ((inform (number->string (+ (single-query (hilite (make-number "enter 10"))) (single-query (make-number "enter 20")))))) ; this step looks wrong wrong wrong. - ((inform (number->string (+ (single-query (hilite (make-numeric "enter 10"))) (single-query (make-number "enter 20"))))))) - (before-after ((inform (number->string (+ (hilite (single-query (make-numeric "enter 10"))) (single-query (make-number "enter 20")))))) - ((inform (number->string (+ (hilite 10) (single-query (make-number "enter 20"))))))) - (before-after ((inform (number->string (+ 10 (single-query (hilite (make-number "enter 20"))))))) - ((inform (number->string (+ 10 (single-query (hilite (make-numeric "enter 20")))))))) - (before-after ((inform (number->string (+ 10 (hilite (single-query (make-numeric "enter 20"))))))) - ((inform (number->string (+ 10 (hilite 20)))))) - (before-after ((inform (number->string (hilite (+ 10 20))))) - ((inform (number->string (hilite 30))))) - (before-after ((inform (hilite (number->string 30)))) - ((inform (hilite "30")))) - (before-after ((hilite (inform "30"))) - ((hilite true))) - (finished (true))))) - - #;(t teachpack-callbacks - (test-teachpack-sequence " (define (f2c x) x) (convert-gui f2c)" `() ; placeholder - )) - - #;(run-tests '(let-scoping1)) - (run-all-tests) - ) -======= -(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" - ; for xml testing: - #;(lib "class.ss") - #;(all-except (lib "xml-snipclass.ss" "xml") snip-class) - #;(all-except (lib "scheme-snipclass.ss" "xml") snip-class) - #;(lib "mred.ss" "mred")) - - (define test-directory (find-system-path 'temp-dir)) - - (define (stream-ify expr-list iter) - (lambda () - (if (null? expr-list) - (iter eof void) - (iter (expand (car expr-list)) (stream-ify (cdr expr-list) iter))))) - - (define (test-sequence-core namespace-spec teachpack-specs render-settings track-inferred-names? in-port expected-steps) (let* ([current-error-display-handler (error-display-handler)]) (let* ([all-steps