test allowing first-order functions to higher-order primitives
svn: r4669
This commit is contained in:
parent
a44c685ac9
commit
5c940f0c94
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
Loading…
Reference in New Issue
Block a user