test allowing first-order functions to higher-order primitives

svn: r4669

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)

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)))

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)

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
+               (eval
-		#`(module #,name #,current-htdp-lang
+                #`(module #,name #,(add-teachpacks current-htdp-lang)
-		    #,@body-accum
+                    #,@body-accum
-		    #,(strip-context #'expr)))
+                    #,(strip-context #'expr)))
-	       (dynamic-require name #f))]
+               (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)))