diff --git a/collects/tests/mzscheme/advanced.ss b/collects/tests/mzscheme/advanced.ss index 577c11a023..002f9c3aee 100644 --- a/collects/tests/mzscheme/advanced.ss +++ b/collects/tests/mzscheme/advanced.ss @@ -201,4 +201,15 @@ (htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10.02)) 0.1)) (htdp-test #f 'equal~? (equal~? (box (list 10)) (box (list 10.2)) 0.1)) +;; Simulate set! in the repl? +#| +(module my-advanced-module (lib "htdp-advanced.ss" "lang") + (define x 10)) +(require my-advanced-module) +(parameterize ([current-namespace (module->namespace 'my-advanced-module)]) + (eval #'(set! x 12))) +|# + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index fac7f9de60..15d73641b7 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -194,6 +194,29 @@ (htdp-top-pop 1) (htdp-top-pop 1) +;; Teachpacks with higher-order primitives +;; Some further tests are in beg-bega.ss +(module my-teachpack mzscheme + (require (lib "prim.ss" "lang")) + (provide go) + (define-higher-order-primitive go real-go (_ proc)) + (define (real-go a b) a)) +(htdp-teachpack my-teachpack) + +(htdp-top (define (my-f x) x)) +(htdp-top (define-struct foo (a b))) + +(htdp-test 5 'tp (go 5 add1)) +(htdp-test 5 'tp (go 5 my-f)) +(htdp-test 5 'tp (go 5 foo?)) +(htdp-test 5 'tp (go 5 make-foo)) +(htdp-test 5 'tp (go 5 foo-a)) +(htdp-test 5 'tp (go 5 go)) + +(htdp-top-pop 1) +(htdp-top-pop 1) +(htdp-teachpack-pop) + ;; Error messages (htdp-top (define my-x 5)) (htdp-top (define (my-f x) (+ x 5))) diff --git a/collects/tests/mzscheme/beg-bega.ss b/collects/tests/mzscheme/beg-bega.ss index 9855bcc37d..971bfa993d 100644 --- a/collects/tests/mzscheme/beg-bega.ss +++ b/collects/tests/mzscheme/beg-bega.ss @@ -26,3 +26,21 @@ (htdp-top (define (my-f x) (+ x 5))) (htdp-syntax-test #'my-f #rx"a procedure, so it must be applied") (htdp-top-pop 1) + +;; Teachpacks with higher-order primitives +;; Builds on tests in beg-adv.ss +(htdp-teachpack my-teachpack) + +(htdp-top (define (my-f x) x)) +(htdp-top (define-struct foo (a b))) + +(htdp-syntax-test #'(go 5 8)) +(htdp-syntax-test #'(go add1 add1)) +(htdp-syntax-test #'(go my-f add1)) +(htdp-syntax-test #'(go foo? add1)) +(htdp-syntax-test #'(go make-foo add1)) +(htdp-syntax-test #'(go foo-a add1)) +(htdp-syntax-test #'(go go add1)) + +(htdp-top-pop 1) +(htdp-teachpack-pop) diff --git a/collects/tests/mzscheme/htdp-test.ss b/collects/tests/mzscheme/htdp-test.ss index 2a16deefe8..0b473ae9aa 100644 --- a/collects/tests/mzscheme/htdp-test.ss +++ b/collects/tests/mzscheme/htdp-test.ss @@ -23,11 +23,41 @@ null (cons (car body-accum) (loop (cdr body-accum))))))) +(define teachpack-accum null) +(define-syntax (htdp-teachpack stx) + (syntax-case stx () + [(_ lib) + #'(set! teachpack-accum (cons (strip-context (quote-syntax lib)) teachpack-accum))])) +(define (htdp-teachpack-pop) + (set! teachpack-accum (cdr teachpack-accum))) + +(define previous-tp-accum #f) +(define previous-tp-lang #f) +(define (add-teachpacks lang) + (cond + [(null? teachpack-accum) lang] + [(equal? teachpack-accum previous-tp-accum) + previous-tp-lang] + [else + (let ([name (string->symbol (format "~a+tp~a" lang (gensym)))]) + (eval #`(module #,name mzscheme + (define-syntax (bounce stx) + #'(begin + (require #,lang #,@teachpack-accum) + (provide (all-from #,lang) + #,@(map (lambda (tp) + #`(all-from #,tp)) + teachpack-accum)))) + (bounce))) + (set! previous-tp-accum teachpack-accum) + (set! previous-tp-lang name) + name)])) + (define htdp-syntax-test (case-lambda [(stx) (htdp-syntax-test stx #rx".")] [(stx rx) - (error-test #`(module m #,current-htdp-lang + (error-test #`(module m #,(add-teachpacks current-htdp-lang) #,@body-accum #,(strip-context stx)) (lambda (x) @@ -49,11 +79,11 @@ ;; double-check that there's no error, at least, ;; when using the real module-begin: #'(mz-let ([name (gensym)]) - (eval - #`(module #,name #,current-htdp-lang - #,@body-accum - #,(strip-context #'expr))) - (dynamic-require name #f))] + (eval + #`(module #,name #,(add-teachpacks current-htdp-lang) + #,@body-accum + #,(strip-context #'expr))) + (dynamic-require name #f))] [_ (printf "~s\n" (syntax-object->datum stx)) #'(void)])) @@ -77,10 +107,10 @@ (module helper mzscheme (define-syntax (module-begin stx) (syntax-case stx () - [(_ the-test lang to-export . rest) + [(_ the-test lang to-export requires . rest) #`(#%module-begin (require (rename tester the-test test)) - (require lang) + (require lang . requires) #,@(if (syntax-object->datum (syntax to-export)) (list (syntax (provide to-export))) '()) @@ -98,6 +128,7 @@ test (all-except #,current-htdp-lang #%module-begin) #f + #,teachpack-accum #,@body-accum #,(strip-context stx))) (unless stx-err? @@ -116,6 +147,7 @@ test (all-except #,current-htdp-lang #%module-begin) the-answer + #,teachpack-accum #,@body-accum (define the-answer #,(strip-context stx)))) (dynamic-require name 'the-answer)))