suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added optional arg to expand-teaching-program

Browse Source 
svn: r8766
This commit is contained in:
John Clements 2008-02-22 20:53:39 +00:00
parent 46f6deeae9
commit cc2e1464e8
1 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/lang/run-teaching-program.ss
View File

@ -7,14 +7,15 @@
scheme/contract) scheme/contract)
(provide/contract (provide/contract
[expand-teaching-program (-> input-port? [expand-teaching-program (->* (input-port?
(-> any/c input-port? any/c) (-> any/c input-port? any/c)
any/c any/c
(listof any/c) (listof any/c)
(or/c false/c (object-contract [display-results/void (-> (listof any/c) any)])) (or/c false/c (object-contract [display-results/void (-> (listof any/c) any)])))
(symbol?)
any)]) any)])
(define (expand-teaching-program port reader language-module teachpacks rep) (define (expand-teaching-program port reader language-module teachpacks rep [module-name '#%htdp])
(let ([state 'init] (let ([state 'init]
;; state : 'init => 'require => 'done-or-exn ;; state : 'init => 'require => 'done-or-exn
@ -32,7 +33,7 @@
(expand (expand
(datum->syntax (datum->syntax
#f #f
`(,#'module #%htdp ,language-module `(,#'module ,module-name ,language-module
,@(map (λ (x) ,@(map (λ (x)
`(require ,x)) `(require ,x))
teachpacks)))))]) teachpacks)))))])
@ -53,23 +54,23 @@
(expand (expand
(datum->syntax (datum->syntax
#f #f
`(,#'module #%htdp ,language-module `(,#'module ,module-name ,language-module
,@(map (λ (x) `(require ,x)) teachpacks) ,@(map (λ (x) `(require ,x)) teachpacks)
,@body-exps))) ,@body-exps)))
rep)))] rep)))]
[(require) [(require)
(set! state 'done-or-exn) (set! state 'done-or-exn)
(stepper-syntax-property (stepper-syntax-property
(syntax (quasisyntax
(let ([done-already? #f]) (let ([done-already? #f])
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(dynamic-require ''#%htdp #f)) ;; work around a bug in dynamic-require (dynamic-require ''#,module-name #f)) ;; work around a bug in dynamic-require
(lambda () (lambda ()
(unless done-already? (unless done-already?
(set! done-already? #t) (set! done-already? #t)
(current-namespace (module->namespace ''#%htdp))))))) (current-namespace (module->namespace ''#,module-name)))))))
'stepper-skip-completely 'stepper-skip-completely
#t)] #t)]
[(done-or-exn) [(done-or-exn)