test allowing first-order functions to higher-order primitives

svn: r4669
This commit is contained in:
Matthew Flatt 2006-10-22 01:46:02 +00:00
parent a44c685ac9
commit 5c940f0c94
4 changed files with 92 additions and 8 deletions

View File

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

View File

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

View File

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

View File

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