Fixing certification tests
svn: r6294
This commit is contained in:
Jay McCarthy
parent
0b74eca282
commit
ec228f9092
|
|
@ -1,5 +1,6 @@
|
|||
(module lang mzscheme
|
||||
(require-for-syntax (lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"labels.ss"
|
||||
"lang/util.ss"
|
||||
"lang/elim-letrec.ss"
|
||||
|
|
|
|||
|
|
@ -34,133 +34,135 @@
|
|||
(anormal id stx))
|
||||
|
||||
(define (anormal ctxt stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin)
|
||||
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
|
||||
[(begin lbe)
|
||||
(anormal ctxt (syntax/loc stx lbe))]
|
||||
[(begin fbe be ...)
|
||||
; XXX Am I a bug?
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(throw-away) fbe])
|
||||
(begin be ...))))]
|
||||
[(begin0)
|
||||
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
|
||||
[(begin0 lbe)
|
||||
(anormal ctxt (syntax/loc stx lbe))]
|
||||
[(begin0 fbe be ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(save) fbe])
|
||||
(begin be ... save))))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx (set! v #,val))))
|
||||
#'ve)]
|
||||
[(let-values () be)
|
||||
(anormal ctxt (syntax/loc stx be))]
|
||||
[(let-values ([(v) ve]) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(#%app (lambda (v) be)
|
||||
ve)))]
|
||||
[(let-values ([(v ...) ve]) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (v ...) be))))]
|
||||
[(let-values ([(fv ...) fve] [(v ...) ve] ...) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(fv ...) fve])
|
||||
(let-values ([(v ...) ve] ...)
|
||||
be))))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...)
|
||||
(begin be ...))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(anormal ctxt
|
||||
(elim-letrec-term stx))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))])
|
||||
(ctxt (syntax/loc stx (lambda formals nbe))))]
|
||||
[(case-lambda [formals be] ...)
|
||||
(with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))])
|
||||
(ctxt (syntax/loc stx (case-lambda [formals be] ...))))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx (case-lambda [formals (begin be ...)] ...)))]
|
||||
[(if te ce ae)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx
|
||||
(if #,val
|
||||
#,(anormal-term #'ce)
|
||||
#,(anormal-term #'ae)))))
|
||||
#'te)]
|
||||
[(if te ce)
|
||||
(anormal ctxt (syntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
(ctxt stx)]
|
||||
[(quote-syntax datum)
|
||||
(ctxt stx)]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (kev)
|
||||
(anormal
|
||||
(lambda (mev)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark #,kev #,mev
|
||||
#,(anormal-term #'be))))
|
||||
#'me)))
|
||||
#'ke)]
|
||||
[(#%expression . d)
|
||||
(ctxt stx)]
|
||||
[(#%app fe e ...)
|
||||
(anormal
|
||||
(lambda (val0)
|
||||
(anormal*
|
||||
(compose ctxt
|
||||
(lambda (rest-vals)
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,val0 #,@rest-vals))))
|
||||
(syntax->list #'(e ...))))
|
||||
#'fe)]
|
||||
[(#%top . v)
|
||||
(ctxt stx)]
|
||||
[(#%datum . d)
|
||||
(ctxt stx)]
|
||||
[(#%variable-reference . v)
|
||||
(ctxt stx)]
|
||||
[id (identifier? #'id)
|
||||
(ctxt #'id)]
|
||||
[_
|
||||
(raise-syntax-error 'anormal "Dropped through:" stx)]))
|
||||
(recertify
|
||||
stx
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin)
|
||||
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
|
||||
[(begin lbe)
|
||||
(anormal ctxt (syntax/loc stx lbe))]
|
||||
[(begin fbe be ...)
|
||||
; XXX Am I a bug?
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(throw-away) fbe])
|
||||
(begin be ...))))]
|
||||
[(begin0)
|
||||
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
|
||||
[(begin0 lbe)
|
||||
(anormal ctxt (syntax/loc stx lbe))]
|
||||
[(begin0 fbe be ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(save) fbe])
|
||||
(begin be ... save))))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx (set! v #,val))))
|
||||
#'ve)]
|
||||
[(let-values () be)
|
||||
(anormal ctxt (syntax/loc stx be))]
|
||||
[(let-values ([(v) ve]) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(#%app (lambda (v) be)
|
||||
ve)))]
|
||||
[(let-values ([(v ...) ve]) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (v ...) be))))]
|
||||
[(let-values ([(fv ...) fve] [(v ...) ve] ...) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(fv ...) fve])
|
||||
(let-values ([(v ...) ve] ...)
|
||||
be))))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...)
|
||||
(begin be ...))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(anormal ctxt
|
||||
(elim-letrec-term stx))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))])
|
||||
(ctxt (syntax/loc stx (lambda formals nbe))))]
|
||||
[(case-lambda [formals be] ...)
|
||||
(with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))])
|
||||
(ctxt (syntax/loc stx (case-lambda [formals be] ...))))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx (case-lambda [formals (begin be ...)] ...)))]
|
||||
[(if te ce ae)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx
|
||||
(if #,val
|
||||
#,(anormal-term #'ce)
|
||||
#,(anormal-term #'ae)))))
|
||||
#'te)]
|
||||
[(if te ce)
|
||||
(anormal ctxt (syntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
(ctxt stx)]
|
||||
[(quote-syntax datum)
|
||||
(ctxt stx)]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (kev)
|
||||
(anormal
|
||||
(lambda (mev)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark #,kev #,mev
|
||||
#,(anormal-term #'be))))
|
||||
#'me)))
|
||||
#'ke)]
|
||||
[(#%expression . d)
|
||||
(ctxt stx)]
|
||||
[(#%app fe e ...)
|
||||
(anormal
|
||||
(lambda (val0)
|
||||
(anormal*
|
||||
(compose ctxt
|
||||
(lambda (rest-vals)
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,val0 #,@rest-vals))))
|
||||
(syntax->list #'(e ...))))
|
||||
#'fe)]
|
||||
[(#%top . v)
|
||||
(ctxt stx)]
|
||||
[(#%datum . d)
|
||||
(ctxt stx)]
|
||||
[(#%variable-reference . v)
|
||||
(ctxt stx)]
|
||||
[id (identifier? #'id)
|
||||
(ctxt #'id)]
|
||||
[_
|
||||
(raise-syntax-error 'anormal "Dropped through:" stx)])))
|
||||
|
||||
;; anormal*: ((listof w) -> target-expr) (listof source-expr) -> target-expr
|
||||
;; normalize an expression given as a context and list of sub-expressions
|
||||
|
|
|
|||
|
|
@ -15,123 +15,126 @@
|
|||
; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3])
|
||||
; defunctionalizes the first syntax, returning the second and the lifted lambdas [3]
|
||||
(define (defun stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
|
||||
(values (quasisyntax/loc stx (begin #,@nbes))
|
||||
defs))]
|
||||
[(begin0 be ...)
|
||||
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
|
||||
(values (quasisyntax/loc stx (begin0 #,@nbes))
|
||||
defs))]
|
||||
[(define-values (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-values (v ...) #,nve))
|
||||
defs))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
|
||||
defs))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve))
|
||||
defs))]
|
||||
[(set! v ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (set! v #,nve))
|
||||
defs))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))
|
||||
(append ve-defs be-defs))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))
|
||||
(append ve-defs be-defs))))]
|
||||
[(lambda formals be ...)
|
||||
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nbe ...) nbes])
|
||||
(let ([fvars (free-vars stx)])
|
||||
(let-values ([(make-CLOSURE new-defs)
|
||||
(make-closure-definition-syntax
|
||||
(make-new-closure-label (current-code-labeling) stx)
|
||||
fvars
|
||||
(syntax/loc stx (lambda formals nbe ...)))])
|
||||
(values (if (empty? fvars)
|
||||
(quasisyntax/loc stx (#,make-CLOSURE))
|
||||
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(append be-defs new-defs))))))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
|
||||
(with-syntax ([((nbe ...) ...) nbes])
|
||||
(let ([fvars (free-vars stx)])
|
||||
(let-values ([(make-CLOSURE new-defs)
|
||||
(make-closure-definition-syntax
|
||||
(make-new-closure-label (current-code-labeling) stx)
|
||||
fvars
|
||||
(syntax/loc stx (case-lambda [formals nbe ...] ...)))])
|
||||
(values (if (empty? fvars)
|
||||
(quasisyntax/loc stx (#,make-CLOSURE))
|
||||
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(append be-defs new-defs))))))]
|
||||
[(if te ce ae)
|
||||
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
|
||||
(values (quasisyntax/loc stx (if #,@es))
|
||||
defs))]
|
||||
[(if te ce)
|
||||
(defun (quasisyntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
(values stx
|
||||
empty)]
|
||||
[(quote-syntax datum)
|
||||
(values stx
|
||||
empty)]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(let-values ([(nses se-defs) (defun* (syntax->list #'(se ...)))]
|
||||
[(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nse ...) nses]
|
||||
[(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx
|
||||
(letrec-syntaxes+values ([(sv ...) nse] ...)
|
||||
([(vv ...) nve] ...)
|
||||
nbe ...))
|
||||
(append se-defs ve-defs be-defs))))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
|
||||
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
|
||||
defs))]
|
||||
[(#%expression . d)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%app e ...)
|
||||
(let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
|
||||
(values (quasisyntax/loc stx (#%app #,@es))
|
||||
defs))]
|
||||
[(#%top . v)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%datum . d)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%variable-reference . v)
|
||||
(values stx
|
||||
empty)]
|
||||
[id (identifier? #'id)
|
||||
(recertify/new-defs
|
||||
stx
|
||||
(lambda ()
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
|
||||
(values (quasisyntax/loc stx (begin #,@nbes))
|
||||
defs))]
|
||||
[(begin0 be ...)
|
||||
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
|
||||
(values (quasisyntax/loc stx (begin0 #,@nbes))
|
||||
defs))]
|
||||
[(define-values (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-values (v ...) #,nve))
|
||||
defs))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
|
||||
defs))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve))
|
||||
defs))]
|
||||
[(set! v ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (set! v #,nve))
|
||||
defs))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))
|
||||
(append ve-defs be-defs))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))
|
||||
(append ve-defs be-defs))))]
|
||||
[(lambda formals be ...)
|
||||
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nbe ...) nbes])
|
||||
(let ([fvars (free-vars stx)])
|
||||
(let-values ([(make-CLOSURE new-defs)
|
||||
(make-closure-definition-syntax
|
||||
(make-new-closure-label (current-code-labeling) stx)
|
||||
fvars
|
||||
(syntax/loc stx (lambda formals nbe ...)))])
|
||||
(values (if (empty? fvars)
|
||||
(quasisyntax/loc stx (#,make-CLOSURE))
|
||||
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(append be-defs new-defs))))))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
|
||||
(with-syntax ([((nbe ...) ...) nbes])
|
||||
(let ([fvars (free-vars stx)])
|
||||
(let-values ([(make-CLOSURE new-defs)
|
||||
(make-closure-definition-syntax
|
||||
(make-new-closure-label (current-code-labeling) stx)
|
||||
fvars
|
||||
(syntax/loc stx (case-lambda [formals nbe ...] ...)))])
|
||||
(values (if (empty? fvars)
|
||||
(quasisyntax/loc stx (#,make-CLOSURE))
|
||||
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(append be-defs new-defs))))))]
|
||||
[(if te ce ae)
|
||||
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
|
||||
(values (quasisyntax/loc stx (if #,@es))
|
||||
defs))]
|
||||
[(if te ce)
|
||||
(defun (quasisyntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
(values stx
|
||||
empty)]
|
||||
[_
|
||||
(raise-syntax-error 'defun "Dropped through:" stx)]))
|
||||
[(quote-syntax datum)
|
||||
(values stx
|
||||
empty)]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(let-values ([(nses se-defs) (defun* (syntax->list #'(se ...)))]
|
||||
[(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nse ...) nses]
|
||||
[(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx
|
||||
(letrec-syntaxes+values ([(sv ...) nse] ...)
|
||||
([(vv ...) nve] ...)
|
||||
nbe ...))
|
||||
(append se-defs ve-defs be-defs))))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
|
||||
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
|
||||
defs))]
|
||||
[(#%expression . d)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%app e ...)
|
||||
(let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
|
||||
(values (quasisyntax/loc stx (#%app #,@es))
|
||||
defs))]
|
||||
[(#%top . v)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%datum . d)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%variable-reference . v)
|
||||
(values stx
|
||||
empty)]
|
||||
[id (identifier? #'id)
|
||||
(values stx
|
||||
empty)]
|
||||
[_
|
||||
(raise-syntax-error 'defun "Dropped through:" stx)]))))
|
||||
|
||||
; lift defun to list of syntaxes
|
||||
(define (lift-defun defun)
|
||||
|
|
|
|||
|
|
@ -10,161 +10,165 @@
|
|||
;; mark-lambda-as-safe: w -> w
|
||||
;; If w is a lambda-expression then add #t to the safety mark, otherwise no mark
|
||||
(define (mark-lambda-as-safe w)
|
||||
(syntax-case w (lambda case-lambda)
|
||||
[(lambda formals be ...)
|
||||
(syntax/loc w
|
||||
(lambda formals
|
||||
(with-continuation-mark safe-call? '(#t (lambda formals))
|
||||
be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(syntax/loc w
|
||||
(case-lambda [formals
|
||||
(with-continuation-mark safe-call? '(#t (case-lambda formals ...))
|
||||
be ...)] ...))]
|
||||
[_else w]))
|
||||
(recertify
|
||||
w
|
||||
(syntax-case w (lambda case-lambda)
|
||||
[(lambda formals be ...)
|
||||
(syntax/loc w
|
||||
(lambda formals
|
||||
(with-continuation-mark safe-call? '(#t (lambda formals))
|
||||
be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(syntax/loc w
|
||||
(case-lambda [formals
|
||||
(with-continuation-mark safe-call? '(#t (case-lambda formals ...))
|
||||
be ...)] ...))]
|
||||
[_else w])))
|
||||
|
||||
(define (elim-callcc stx)
|
||||
(elim-callcc/mark id stx))
|
||||
|
||||
(define (elim-callcc/mark markit stx)
|
||||
(kernel-syntax-case*
|
||||
stx #f (call/cc call-with-values)
|
||||
[(begin be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(begin0 be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve (elim-callcc #'ve)])
|
||||
(syntax/loc stx (set! v ve)))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(lambda formals be)
|
||||
(with-syntax ([be (elim-callcc #'be)])
|
||||
(syntax/loc stx
|
||||
(lambda formals be)))]
|
||||
[(case-lambda [formals be] ...)
|
||||
(with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te (elim-callcc #'te)]
|
||||
[ce (elim-callcc #'ce)]
|
||||
[ae (elim-callcc #'ae)])
|
||||
(markit (syntax/loc stx (if te ce ae))))]
|
||||
[(if te ce)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(let* ([ke-prime (elim-callcc #'ke)]
|
||||
[me-prime (elim-callcc #'me)]
|
||||
[be-prime (elim-callcc #'be)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark #,ke-prime #,me-prime
|
||||
(with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime)
|
||||
#,be-prime)))))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app call/cc w)
|
||||
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
|
||||
[(x ref-to-x) (generate-formal 'x)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,(elim-callcc #'w)
|
||||
(#%app (lambda (#,cm)
|
||||
(lambda #,x
|
||||
(#%app abort
|
||||
(lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
|
||||
(#%app activation-record-list))))))]
|
||||
[(#%app call-with-values (lambda () prod) cons)
|
||||
(let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app call-with-values
|
||||
#,(mark-lambda-as-safe
|
||||
(quasisyntax/loc stx
|
||||
(lambda ()
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,cons-prime #,x)))
|
||||
#'prod))))
|
||||
#,cons-prime))))]
|
||||
[(#%app w (#%app . stuff))
|
||||
(with-syntax ([e #'(#%app . stuff)])
|
||||
(syntax-case #'w (lambda case-lambda)
|
||||
[(lambda formals body)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'l))])
|
||||
(quasisyntax/loc stx
|
||||
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
|
||||
#,(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,w-prime #,x)))
|
||||
#'e)))))))]
|
||||
[(case-lambda [formals body] ...)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'cl))])
|
||||
(quasisyntax/loc stx
|
||||
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
|
||||
#,(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,w-prime #,x)))
|
||||
#'e)))))))]
|
||||
[_else
|
||||
(let ([w-prime (elim-callcc #'w)])
|
||||
(markit
|
||||
(recertify
|
||||
stx
|
||||
(kernel-syntax-case*
|
||||
stx #f (call/cc call-with-values)
|
||||
[(begin be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(begin0 be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve (elim-callcc #'ve)])
|
||||
(syntax/loc stx (set! v ve)))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(lambda formals be)
|
||||
(with-syntax ([be (elim-callcc #'be)])
|
||||
(syntax/loc stx
|
||||
(lambda formals be)))]
|
||||
[(case-lambda [formals be] ...)
|
||||
(with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te (elim-callcc #'te)]
|
||||
[ce (elim-callcc #'ce)]
|
||||
[ae (elim-callcc #'ae)])
|
||||
(markit (syntax/loc stx (if te ce ae))))]
|
||||
[(if te ce)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(let* ([ke-prime (elim-callcc #'ke)]
|
||||
[me-prime (elim-callcc #'me)]
|
||||
[be-prime (elim-callcc #'be)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark #,ke-prime #,me-prime
|
||||
(with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime)
|
||||
#,be-prime)))))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app call/cc w)
|
||||
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
|
||||
[(x ref-to-x) (generate-formal 'x)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,(elim-callcc #'w)
|
||||
(#%app (lambda (#,cm)
|
||||
(lambda #,x
|
||||
(#%app abort
|
||||
(lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
|
||||
(#%app activation-record-list))))))]
|
||||
[(#%app call-with-values (lambda () prod) cons)
|
||||
(let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app call-with-values
|
||||
#,(mark-lambda-as-safe
|
||||
(quasisyntax/loc stx
|
||||
(lambda ()
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,cons-prime #,x)))
|
||||
#'prod))))
|
||||
#,cons-prime))))]
|
||||
[(#%app w (#%app . stuff))
|
||||
(with-syntax ([e #'(#%app . stuff)])
|
||||
(syntax-case #'w (lambda case-lambda)
|
||||
[(lambda formals body)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'l))])
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
#`(with-continuation-mark the-cont-key #,w-prime #,x))
|
||||
#'e)))))]))]
|
||||
[(#%app w rest ...)
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark safe-call? '(#f #,stx)
|
||||
(#%app #,(mark-lambda-as-safe (elim-callcc #'w))
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(mark-lambda-as-safe
|
||||
(elim-callcc
|
||||
an-expr)))
|
||||
(syntax->list #'(rest ...)))))))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
stx]
|
||||
[_
|
||||
(raise-syntax-error 'elim-callcc "Dropped through:" stx)])))
|
||||
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
|
||||
#,(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,w-prime #,x)))
|
||||
#'e)))))))]
|
||||
[(case-lambda [formals body] ...)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'cl))])
|
||||
(quasisyntax/loc stx
|
||||
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
|
||||
#,(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,w-prime #,x)))
|
||||
#'e)))))))]
|
||||
[_else
|
||||
(let ([w-prime (elim-callcc #'w)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
#`(with-continuation-mark the-cont-key #,w-prime #,x))
|
||||
#'e)))))]))]
|
||||
[(#%app w rest ...)
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark safe-call? '(#f #,stx)
|
||||
(#%app #,(mark-lambda-as-safe (elim-callcc #'w))
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(mark-lambda-as-safe
|
||||
(elim-callcc
|
||||
an-expr)))
|
||||
(syntax->list #'(rest ...)))))))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
stx]
|
||||
[_
|
||||
(raise-syntax-error 'elim-callcc "Dropped through:" stx)]))))
|
||||
|
|
@ -11,127 +11,129 @@
|
|||
; Eliminates letrec-values from syntax[2] and correctly handles references to
|
||||
; letrec-bound variables [3] therein.
|
||||
(define ((elim-letrec ids) stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin be ...)))]
|
||||
[(begin0 be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin0 be ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
(syntax/loc stx (#%app set-box! id ve))
|
||||
(syntax/loc stx (set! id ve))))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(with-syntax ([(ve ...) (map (elim-letrec ids) (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...) be ...)))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))])
|
||||
(with-syntax ([((nv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((v ...) ...)))]
|
||||
[((nv-box ...) ...) (map (lambda (nvs)
|
||||
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
|
||||
(syntax->list nvs)))
|
||||
(syntax->list #`((v ...) ...)))]
|
||||
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
|
||||
; XXX Optimize special case of one nv
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...)
|
||||
(#%app values nv-box ...)] ...)
|
||||
(begin (#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (nv ...)
|
||||
(#%app set-box! v nv) ...))
|
||||
...
|
||||
be ...)))))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda formals be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(with-syntax ([((be ...) ...) (map (elim-letrec ids) (syntax->list #'((be ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be ...] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te ((elim-letrec ids) #'te)]
|
||||
[ce ((elim-letrec ids) #'ce)]
|
||||
[ae ((elim-letrec ids) #'ae)])
|
||||
(syntax/loc stx
|
||||
(if te ce ae)))]
|
||||
[(if te ce)
|
||||
((elim-letrec ids)
|
||||
(syntax/loc stx
|
||||
(if te ce (#%app (#%top . void)))))]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((vv ...) ...))))])
|
||||
(with-syntax ([((nvv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((vv ...) ...)))]
|
||||
[((nvv-box ...) ...) (map (lambda (nvs)
|
||||
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
|
||||
(syntax->list nvs)))
|
||||
(syntax->list #`((vv ...) ...)))]
|
||||
[(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))]
|
||||
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
|
||||
; XXX Optimize special case of one nv
|
||||
(syntax/loc stx
|
||||
(let-values ([(vv ...)
|
||||
(#%app values nvv-box ...)] ...)
|
||||
; This is okay, because we've already expanded the syntax.
|
||||
(let-syntaxes
|
||||
([(sv ...) se] ...)
|
||||
(begin (#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (nvv ...)
|
||||
(#%app set-box! vv nvv) ...))
|
||||
...
|
||||
be ...))))))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(with-syntax ([ke ((elim-letrec ids) #'ke)]
|
||||
[me ((elim-letrec ids) #'me)]
|
||||
[be ((elim-letrec ids) #'be)])
|
||||
(syntax/loc stx
|
||||
(with-continuation-mark ke me be)))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app e ...)
|
||||
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
|
||||
(syntax/loc stx
|
||||
(#%app e ...)))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
(recertify
|
||||
stx
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin be ...)))]
|
||||
[(begin0 be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin0 be ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
(syntax/loc stx (#%app unbox id))
|
||||
#'id)]
|
||||
[_
|
||||
(raise-syntax-error 'elim-letrec "Dropped through:" stx)]))
|
||||
(syntax/loc stx (#%app set-box! id ve))
|
||||
(syntax/loc stx (set! id ve))))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(with-syntax ([(ve ...) (map (elim-letrec ids) (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...) be ...)))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))])
|
||||
(with-syntax ([((nv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((v ...) ...)))]
|
||||
[((nv-box ...) ...) (map (lambda (nvs)
|
||||
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
|
||||
(syntax->list nvs)))
|
||||
(syntax->list #`((v ...) ...)))]
|
||||
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
|
||||
; XXX Optimize special case of one nv
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...)
|
||||
(#%app values nv-box ...)] ...)
|
||||
(begin (#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (nv ...)
|
||||
(#%app set-box! v nv) ...))
|
||||
...
|
||||
be ...)))))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda formals be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(with-syntax ([((be ...) ...) (map (elim-letrec ids) (syntax->list #'((be ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be ...] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te ((elim-letrec ids) #'te)]
|
||||
[ce ((elim-letrec ids) #'ce)]
|
||||
[ae ((elim-letrec ids) #'ae)])
|
||||
(syntax/loc stx
|
||||
(if te ce ae)))]
|
||||
[(if te ce)
|
||||
((elim-letrec ids)
|
||||
(syntax/loc stx
|
||||
(if te ce (#%app (#%top . void)))))]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((vv ...) ...))))])
|
||||
(with-syntax ([((nvv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((vv ...) ...)))]
|
||||
[((nvv-box ...) ...) (map (lambda (nvs)
|
||||
(map (lambda (x) (syntax/loc x (#%app box the-undef)))
|
||||
(syntax->list nvs)))
|
||||
(syntax->list #`((vv ...) ...)))]
|
||||
[(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))]
|
||||
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
|
||||
; XXX Optimize special case of one nv
|
||||
(syntax/loc stx
|
||||
(let-values ([(vv ...)
|
||||
(#%app values nvv-box ...)] ...)
|
||||
; This is okay, because we've already expanded the syntax.
|
||||
(let-syntaxes
|
||||
([(sv ...) se] ...)
|
||||
(begin (#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (nvv ...)
|
||||
(#%app set-box! vv nvv) ...))
|
||||
...
|
||||
be ...))))))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(with-syntax ([ke ((elim-letrec ids) #'ke)]
|
||||
[me ((elim-letrec ids) #'me)]
|
||||
[be ((elim-letrec ids) #'be)])
|
||||
(syntax/loc stx
|
||||
(with-continuation-mark ke me be)))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app e ...)
|
||||
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
|
||||
(syntax/loc stx
|
||||
(#%app e ...)))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
(syntax/loc stx (#%app unbox id))
|
||||
#'id)]
|
||||
[_
|
||||
(raise-syntax-error 'elim-letrec "Dropped through:" stx)])))
|
||||
|
||||
(define elim-letrec-term (elim-letrec empty)))
|
||||
|
|
@ -4,6 +4,21 @@
|
|||
(lib "list.ss"))
|
||||
(provide (all-defined))
|
||||
|
||||
(define (recertify old-expr expr)
|
||||
(syntax-recertify expr old-expr (current-code-inspector) #f))
|
||||
|
||||
(define (recertify* old-expr exprs)
|
||||
(map (lambda (expr)
|
||||
(syntax-recertify expr old-expr (current-code-inspector) #f))
|
||||
exprs))
|
||||
|
||||
(define (recertify/new-defs old-expr thunk)
|
||||
(call-with-values
|
||||
thunk
|
||||
(lambda (expr new-defs)
|
||||
(values (recertify old-expr expr)
|
||||
(recertify* old-expr new-defs)))))
|
||||
|
||||
(define current-code-labeling
|
||||
(make-parameter
|
||||
(lambda (stx)
|
||||
|
|
@ -27,70 +42,78 @@
|
|||
(list* #'rv (syntax->list #'(v ...)))]))
|
||||
|
||||
(define ((make-define-case inner) stx)
|
||||
(syntax-case stx (define-values define-syntaxes define-values-for-syntax)
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[_
|
||||
(raise-syntax-error 'define-case "Dropped through:" stx)]))
|
||||
(recertify
|
||||
stx
|
||||
(syntax-case stx (define-values define-syntaxes define-values-for-syntax)
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[_
|
||||
(raise-syntax-error 'define-case "Dropped through:" stx)])))
|
||||
|
||||
(define ((make-define-case/new-defs inner) stx)
|
||||
(let-values ([(nstx defs) (inner stx)])
|
||||
(append defs (list nstx))))
|
||||
|
||||
(define ((make-module-case/new-defs inner) stx)
|
||||
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
|
||||
[(require spec ...)
|
||||
(list stx)]
|
||||
[(provide spec ...)
|
||||
(list stx)]
|
||||
[(require-for-syntax spec ...)
|
||||
(list stx)]
|
||||
[(require-for-template spec ...)
|
||||
(list stx)]
|
||||
[_
|
||||
(inner stx)]))
|
||||
(recertify*
|
||||
stx
|
||||
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
|
||||
[(require spec ...)
|
||||
(list stx)]
|
||||
[(provide spec ...)
|
||||
(list stx)]
|
||||
[(require-for-syntax spec ...)
|
||||
(list stx)]
|
||||
[(require-for-template spec ...)
|
||||
(list stx)]
|
||||
[_
|
||||
(inner stx)])))
|
||||
|
||||
(define ((make-module-case inner) stx)
|
||||
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
|
||||
[(require spec ...)
|
||||
stx]
|
||||
[(provide spec ...)
|
||||
stx]
|
||||
[(require-for-syntax spec ...)
|
||||
stx]
|
||||
[(require-for-template spec ...)
|
||||
stx]
|
||||
[_
|
||||
(inner stx)]))
|
||||
(recertify
|
||||
stx
|
||||
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
|
||||
[(require spec ...)
|
||||
stx]
|
||||
[(provide spec ...)
|
||||
stx]
|
||||
[(require-for-syntax spec ...)
|
||||
stx]
|
||||
[(require-for-template spec ...)
|
||||
stx]
|
||||
[_
|
||||
(inner stx)])))
|
||||
|
||||
(define ((make-lang-module-begin make-labeling transform) stx)
|
||||
(syntax-case stx ()
|
||||
((mb forms ...)
|
||||
(with-syntax ([(pmb rfs body ...)
|
||||
(local-expand (quasisyntax/loc stx
|
||||
(#%plain-module-begin
|
||||
#,(syntax-local-introduce #'(require-for-syntax mzscheme))
|
||||
forms ...))
|
||||
'module-begin
|
||||
empty)])
|
||||
(let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))])
|
||||
(parameterize ([current-code-labeling
|
||||
(lambda (stx)
|
||||
(datum->syntax-object stx (base-labeling)))])
|
||||
(let ([new-defs (apply append (map transform (syntax->list #'(body ...))))])
|
||||
(quasisyntax/loc stx
|
||||
(pmb rfs
|
||||
#,@new-defs)))))))))
|
||||
(recertify
|
||||
stx
|
||||
(syntax-case stx ()
|
||||
((mb forms ...)
|
||||
(with-syntax ([(pmb rfs body ...)
|
||||
(local-expand (quasisyntax/loc stx
|
||||
(#%plain-module-begin
|
||||
#,(syntax-local-introduce #'(require-for-syntax mzscheme))
|
||||
forms ...))
|
||||
'module-begin
|
||||
empty)])
|
||||
(let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))])
|
||||
(parameterize ([current-code-labeling
|
||||
(lambda (stx)
|
||||
(datum->syntax-object stx (base-labeling)))])
|
||||
(let ([new-defs (apply append (map transform (syntax->list #'(body ...))))])
|
||||
(quasisyntax/loc stx
|
||||
(pmb rfs
|
||||
#,@new-defs))))))))))
|
||||
|
||||
(define (bound-identifier-member? id ids)
|
||||
(ormap
|
||||
|
|
@ -100,91 +123,93 @@
|
|||
|
||||
;; Kernel Case Template
|
||||
(define (template stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin be ...)))]
|
||||
[(begin0 be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin0 be ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(set! v ve)))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...) be ...)))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(letrec-values ([(v ...) ve] ...) be ...)))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda formals be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be ...] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te (template #'te)]
|
||||
[ce (template #'ce)]
|
||||
[ae (template #'ae)])
|
||||
(syntax/loc stx
|
||||
(if te ce ae)))]
|
||||
[(if te ce)
|
||||
(template (syntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(with-syntax ([(se ...) (map template (syntax->list #'(se ...)))]
|
||||
[(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(with-syntax ([ke (template #'ke)]
|
||||
[me (template #'me)]
|
||||
[be (template #'be)])
|
||||
(syntax/loc stx
|
||||
(with-continuation-mark ke me be)))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app e ...)
|
||||
(with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
|
||||
(syntax/loc stx
|
||||
(#%app e ...)))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
stx]
|
||||
[_
|
||||
(raise-syntax-error 'kerncase "Dropped through:" stx)])))
|
||||
(recertify
|
||||
stx
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin be ...)))]
|
||||
[(begin0 be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(begin0 be ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(set! v ve)))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...) be ...)))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(letrec-values ([(v ...) ve] ...) be ...)))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda formals be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be ...] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te (template #'te)]
|
||||
[ce (template #'ce)]
|
||||
[ae (template #'ae)])
|
||||
(syntax/loc stx
|
||||
(if te ce ae)))]
|
||||
[(if te ce)
|
||||
(template (syntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(with-syntax ([(se ...) (map template (syntax->list #'(se ...)))]
|
||||
[(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(with-syntax ([ke (template #'ke)]
|
||||
[me (template #'me)]
|
||||
[be (template #'be)])
|
||||
(syntax/loc stx
|
||||
(with-continuation-mark ke me be)))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app e ...)
|
||||
(with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
|
||||
(syntax/loc stx
|
||||
(#%app e ...)))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
stx]
|
||||
[_
|
||||
(raise-syntax-error 'kerncase "Dropped through:" stx)]))))
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
(module certify-tests mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
"language-tester.ss")
|
||||
(provide certify-suite)
|
||||
|
||||
(define certify-suite
|
||||
(make-test-suite
|
||||
"Test the certification process"
|
||||
|
||||
(make-test-suite
|
||||
"Splicing tests"
|
||||
|
||||
(make-test-case
|
||||
"quasi-quote with splicing: need to recertify context for qq-append"
|
||||
(let-values ([(go test-m01.1)
|
||||
(make-module-eval
|
||||
(module m01.1 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
`(,@(list 1 2 initial)))))])
|
||||
(go)
|
||||
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
|
||||
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
|
||||
|
||||
(make-test-case
|
||||
"recertify context test (1)"
|
||||
(let-values ([(go test-m01.2)
|
||||
(make-module-eval
|
||||
(module m01.1 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
`(foo ,@(list 1 2 3)))))])
|
||||
(go)
|
||||
(assert-true #t)))
|
||||
|
||||
(make-test-case
|
||||
"recertify context test (2)"
|
||||
(let-values ([(go test-m01.3)
|
||||
(make-module-eval
|
||||
(module m01.3 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start n)
|
||||
`(n ,@(list 1 2 3)))))])
|
||||
(go)
|
||||
(assert-true #t)))
|
||||
|
||||
(make-test-case
|
||||
"recertify context test (3)"
|
||||
(let-values ([(go test-m01.4)
|
||||
(make-module-eval
|
||||
(module m1 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(define (bar n)
|
||||
`(n ,@(list 1 2 3)))
|
||||
(bar 7))))])
|
||||
(go)
|
||||
(assert-true #t)))))))
|
||||
|
|
@ -27,36 +27,36 @@
|
|||
(make-test-case
|
||||
"Function application with single argument in tail position"
|
||||
(let-values ([(go test-m00.4)
|
||||
(make-module-eval
|
||||
(module m00.4 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(let ([f (let ([m 7]) m)])
|
||||
(+ f initial)))))])
|
||||
(make-module-eval
|
||||
(module m00.4 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(let ([f (let ([m 7]) m)])
|
||||
(+ f initial)))))])
|
||||
(go)
|
||||
(assert = 8 (test-m00.4 '(dispatch-start 1)))))
|
||||
|
||||
(make-test-case
|
||||
"start-interaction in argument position of a function call"
|
||||
(let-values ([(go test-m00.3)
|
||||
(make-module-eval
|
||||
(module m00.3 "../lang.ss"
|
||||
(define (foo x) 'foo)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(foo initial))))])
|
||||
(make-module-eval
|
||||
(module m00.3 "../lang.ss"
|
||||
(define (foo x) 'foo)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(foo initial))))])
|
||||
(go)
|
||||
(assert eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
|
||||
|
||||
(make-test-case
|
||||
"identity interaction, dispatch-start called multiple times"
|
||||
(let-values ([(go test-m00)
|
||||
(make-module-eval
|
||||
(module m00 "../lang.ss"
|
||||
(define (id x) x)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(id initial))))])
|
||||
(make-module-eval
|
||||
(module m00 "../lang.ss"
|
||||
(define (id x) x)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(id initial))))])
|
||||
(go)
|
||||
(assert = 7 (test-m00 '(dispatch-start 7)))
|
||||
(assert eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
|
||||
|
|
@ -64,22 +64,22 @@
|
|||
(make-test-case
|
||||
"start-interaction in argument position of a primitive"
|
||||
(let-values ([(go test-m00.1)
|
||||
(make-module-eval
|
||||
(module m00.1 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ 1 initial))))])
|
||||
(make-module-eval
|
||||
(module m00.1 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ 1 initial))))])
|
||||
(go)
|
||||
(assert = 2 (test-m00.1 '(dispatch-start 1)))))
|
||||
|
||||
(make-test-case
|
||||
"dispatch-start called multiple times for s-i in non-trivial context"
|
||||
(let-values ([(go test-m00.2)
|
||||
(make-module-eval
|
||||
(module m00.2 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ (+ 1 1) initial))))])
|
||||
(make-module-eval
|
||||
(module m00.2 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ (+ 1 1) initial))))])
|
||||
(go)
|
||||
(assert = 14 (test-m00.2 '(dispatch-start 12)))
|
||||
(assert = 20 (test-m00.2 '(dispatch-start 18)))))
|
||||
|
|
@ -87,56 +87,14 @@
|
|||
(make-test-case
|
||||
"start-interaction in third position"
|
||||
(let-values ([(go test-m01)
|
||||
(make-module-eval
|
||||
(module m01 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ (* 1 2) (* 3 4) initial))))])
|
||||
(make-module-eval
|
||||
(module m01 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ (* 1 2) (* 3 4) initial))))])
|
||||
(go)
|
||||
(assert = 14 (test-m01 '(dispatch-start 0)))
|
||||
(assert = 20 (test-m01 '(dispatch-start 6)))))
|
||||
|
||||
(make-test-case
|
||||
"quasi-quote with splicing: need to recertify context for qq-append"
|
||||
(let-values ([(go test-m01.1)
|
||||
(make-module-eval
|
||||
(module m01.1 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
`(,@(list 1 2 initial)))))])
|
||||
(go)
|
||||
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
|
||||
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
|
||||
|
||||
(make-test-case
|
||||
"recertify context test (1)"
|
||||
(let-values ([(go test-m01.2)
|
||||
(make-module-eval
|
||||
(module m01.1 "../lang.ss"
|
||||
`(foo ,@(list 1 2 3))))])
|
||||
(go)
|
||||
(assert-true #t)))
|
||||
|
||||
(make-test-case
|
||||
"recertify context test (2)"
|
||||
(let-values ([(go test-m01.3)
|
||||
(make-module-eval
|
||||
(module m01.3 "../lang.ss"
|
||||
(lambda (n)
|
||||
`(n ,@(list 1 2 3)))))])
|
||||
(go)
|
||||
(assert-true #t)))
|
||||
|
||||
(make-test-case
|
||||
"recertify context test (3)"
|
||||
(let-values ([(go test-m01.4)
|
||||
(make-module-eval
|
||||
(module m1 "../lang.ss"
|
||||
(define (bar n)
|
||||
`(n ,@(list 1 2 3)))
|
||||
(bar 7)))])
|
||||
(go)
|
||||
(assert-true #t)))
|
||||
(assert = 20 (test-m01 '(dispatch-start 6)))))
|
||||
|
||||
;; start-interaction may be called mutitple times
|
||||
;; each call overwrites the previous interaction
|
||||
|
|
@ -166,12 +124,12 @@
|
|||
(make-test-case
|
||||
"continuation invoked in non-trivial context from within proc"
|
||||
(let-values ([(go test-m03)
|
||||
(make-module-eval
|
||||
(module m03 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start x)
|
||||
(let/cc k
|
||||
(+ 2 4 (k 3) 6 8)))))])
|
||||
(make-module-eval
|
||||
(module m03 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start x)
|
||||
(let/cc k
|
||||
(+ 2 4 (k 3) 6 8)))))])
|
||||
(go)
|
||||
(assert = 3 (test-m03 '(dispatch-start 'foo)))
|
||||
(assert = 3 (test-m03 '(dispatch-start 7)))))
|
||||
|
|
@ -182,17 +140,17 @@
|
|||
(make-test-case
|
||||
"non-tail-recursive 'escaping' continuation"
|
||||
(let-values ([(go test-m04)
|
||||
(make-module-eval
|
||||
(module m04 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start ln)
|
||||
(let/cc k
|
||||
(cond
|
||||
[(null? ln) 1]
|
||||
[(zero? (car ln)) (k 0)]
|
||||
[else
|
||||
(* (car ln)
|
||||
(start (cdr ln)))])))))])
|
||||
(make-module-eval
|
||||
(module m04 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start ln)
|
||||
(let/cc k
|
||||
(cond
|
||||
[(null? ln) 1]
|
||||
[(zero? (car ln)) (k 0)]
|
||||
[else
|
||||
(* (car ln)
|
||||
(start (cdr ln)))])))))])
|
||||
(go)
|
||||
(assert = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9))))
|
||||
(assert = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5))))))
|
||||
|
|
@ -204,21 +162,21 @@
|
|||
(make-test-case
|
||||
"tail-recursive escaping continuation"
|
||||
(let-values ([(go test-m05)
|
||||
(make-module-eval
|
||||
(module m05 "../lang.ss"
|
||||
(provide start)
|
||||
|
||||
(define (start ln)
|
||||
(let/cc escape
|
||||
(mult/escape escape ln)))
|
||||
|
||||
(define (mult/escape escape ln)
|
||||
(cond
|
||||
[(null? ln) 1]
|
||||
[(zero? (car ln)) (escape 0)]
|
||||
[else
|
||||
(* (car ln)
|
||||
(mult/escape escape (cdr ln)))]))))])
|
||||
(make-module-eval
|
||||
(module m05 "../lang.ss"
|
||||
(provide start)
|
||||
|
||||
(define (start ln)
|
||||
(let/cc escape
|
||||
(mult/escape escape ln)))
|
||||
|
||||
(define (mult/escape escape ln)
|
||||
(cond
|
||||
[(null? ln) 1]
|
||||
[(zero? (car ln)) (escape 0)]
|
||||
[else
|
||||
(* (car ln)
|
||||
(mult/escape escape (cdr ln)))]))))])
|
||||
(go)
|
||||
(assert = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6))))
|
||||
(assert = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5)))))))
|
||||
|
|
@ -231,65 +189,65 @@
|
|||
|
||||
; XXX This doesn't work, because we don't allow a different dispatcher
|
||||
#;(make-test-case
|
||||
"curried add with send/suspend"
|
||||
(let ([table-01-eval
|
||||
(make-module-eval
|
||||
(module table01 mzscheme
|
||||
(provide store-k
|
||||
lookup-k)
|
||||
|
||||
(define the-table (make-hash-table))
|
||||
|
||||
(define (store-k k)
|
||||
(let ([key (string->symbol (symbol->string (gensym 'key)))])
|
||||
(hash-table-put! the-table key k)
|
||||
key))
|
||||
(define (lookup-k key-pair)
|
||||
(hash-table-get the-table (car key-pair) (lambda () #f)))))])
|
||||
(table-01-eval
|
||||
'(module m06 "../lang.ss"
|
||||
(require table01)
|
||||
(provide start)
|
||||
|
||||
(define (gn which)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "Please send the ~a number.~n" which)])
|
||||
(store-k k))))))
|
||||
|
||||
(define (start ignore)
|
||||
(let ([result (+ (gn "first") (gn "second"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result)))))
|
||||
(table-01-eval '(require m06))
|
||||
(let* ([first-key (table-01-eval '(dispatch-start 'foo))]
|
||||
[second-key (table-01-eval `(dispatch '(,first-key 1)))]
|
||||
[third-key (table-01-eval `(dispatch '(,first-key -7)))])
|
||||
(assert = 3 (table-01-eval `(dispatch '(,second-key 2))))
|
||||
(assert = 4 (table-01-eval `(dispatch '(,second-key 3))))
|
||||
(assert-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
|
||||
(assert = -7 (table-01-eval `(dispatch '(,third-key 0))))
|
||||
(assert-true (zero? (table-01-eval `(dispatch '(,third-key 7))))))))
|
||||
"curried add with send/suspend"
|
||||
(let ([table-01-eval
|
||||
(make-module-eval
|
||||
(module table01 mzscheme
|
||||
(provide store-k
|
||||
lookup-k)
|
||||
|
||||
(define the-table (make-hash-table))
|
||||
|
||||
(define (store-k k)
|
||||
(let ([key (string->symbol (symbol->string (gensym 'key)))])
|
||||
(hash-table-put! the-table key k)
|
||||
key))
|
||||
(define (lookup-k key-pair)
|
||||
(hash-table-get the-table (car key-pair) (lambda () #f)))))])
|
||||
(table-01-eval
|
||||
'(module m06 "../lang.ss"
|
||||
(require table01)
|
||||
(provide start)
|
||||
|
||||
(define (gn which)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "Please send the ~a number.~n" which)])
|
||||
(store-k k))))))
|
||||
|
||||
(define (start ignore)
|
||||
(let ([result (+ (gn "first") (gn "second"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result)))))
|
||||
(table-01-eval '(require m06))
|
||||
(let* ([first-key (table-01-eval '(dispatch-start 'foo))]
|
||||
[second-key (table-01-eval `(dispatch '(,first-key 1)))]
|
||||
[third-key (table-01-eval `(dispatch '(,first-key -7)))])
|
||||
(assert = 3 (table-01-eval `(dispatch '(,second-key 2))))
|
||||
(assert = 4 (table-01-eval `(dispatch '(,second-key 3))))
|
||||
(assert-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
|
||||
(assert = -7 (table-01-eval `(dispatch '(,third-key 0))))
|
||||
(assert-true (zero? (table-01-eval `(dispatch '(,third-key 7))))))))
|
||||
|
||||
(make-test-case
|
||||
"curried with send/suspend and serializaztion"
|
||||
|
||||
(let-values ([(go test-m06.1)
|
||||
(make-module-eval
|
||||
(module m06.1 (lib "lang.ss" "web-server" "prototype-web-server")
|
||||
(provide start)
|
||||
(define (gn which)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "Please send the ~a number.~n" which)])
|
||||
k)))))
|
||||
|
||||
(define (start ignore)
|
||||
(let ([result (+ (gn "first") (gn "second"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result)))))])
|
||||
(make-module-eval
|
||||
(module m06.1 (lib "lang.ss" "web-server" "prototype-web-server")
|
||||
(provide start)
|
||||
(define (gn which)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "Please send the ~a number.~n" which)])
|
||||
k)))))
|
||||
|
||||
(define (start ignore)
|
||||
(let ([result (+ (gn "first") (gn "second"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result)))))])
|
||||
(go)
|
||||
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
|
||||
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
|
||||
|
|
@ -310,17 +268,17 @@
|
|||
(make-test-case
|
||||
"mutually recursive even? and odd?"
|
||||
(let-values ([(go test-m07)
|
||||
(make-module-eval
|
||||
(module m07 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(letrec ([even? (lambda (n)
|
||||
(or (zero? n)
|
||||
(odd? (sub1 n))))]
|
||||
[odd? (lambda (n)
|
||||
(and (not (zero? n))
|
||||
(even? (sub1 n))))])
|
||||
(even? initial)))))])
|
||||
(make-module-eval
|
||||
(module m07 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(letrec ([even? (lambda (n)
|
||||
(or (zero? n)
|
||||
(odd? (sub1 n))))]
|
||||
[odd? (lambda (n)
|
||||
(and (not (zero? n))
|
||||
(even? (sub1 n))))])
|
||||
(even? initial)))))])
|
||||
(go)
|
||||
(assert-true (test-m07 '(dispatch-start 0)))
|
||||
(assert-true (test-m07 '(dispatch-start 16)))
|
||||
|
|
@ -330,24 +288,24 @@
|
|||
(make-test-case
|
||||
"send/suspend on rhs of letrec binding forms"
|
||||
(let-values ([(go test-m08)
|
||||
(make-module-eval
|
||||
(module m08 "../lang.ss"
|
||||
(provide start)
|
||||
(define (gn which)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "Please send the ~a number.~n" which)])
|
||||
k)))))
|
||||
|
||||
(define (start ignore)
|
||||
(letrec ([f (let ([n (gn "first")])
|
||||
(lambda (m) (+ n m)))]
|
||||
[g (let ([n (gn "second")])
|
||||
(lambda (m) (+ n (f m))))])
|
||||
(let ([result (g (gn "third"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result))))))])
|
||||
(make-module-eval
|
||||
(module m08 "../lang.ss"
|
||||
(provide start)
|
||||
(define (gn which)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "Please send the ~a number.~n" which)])
|
||||
k)))))
|
||||
|
||||
(define (start ignore)
|
||||
(letrec ([f (let ([n (gn "first")])
|
||||
(lambda (m) (+ n m)))]
|
||||
[g (let ([n (gn "second")])
|
||||
(lambda (m) (+ n (f m))))])
|
||||
(let ([result (g (gn "third"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result))))))])
|
||||
(go)
|
||||
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))]
|
||||
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))]
|
||||
|
|
@ -367,41 +325,41 @@
|
|||
|
||||
; XXX Bizarre
|
||||
#;(make-test-case
|
||||
"simple attempt to capture a continuation from an unsafe context"
|
||||
|
||||
(let-values ([(go nta-eval)
|
||||
(make-module-eval
|
||||
(module nta mzscheme
|
||||
(provide non-tail-apply)
|
||||
|
||||
(define (non-tail-apply f . args)
|
||||
(let ([result (apply f args)])
|
||||
(printf "result = ~s~n" result)
|
||||
result))))])
|
||||
(nta-eval '(module m09 "../lang.ss"
|
||||
(require nta)
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(non-tail-apply (lambda (x) (let/cc k (k x))) 7))))
|
||||
"simple attempt to capture a continuation from an unsafe context"
|
||||
|
||||
(nta-eval '(require m09))
|
||||
|
||||
(assert-true (catch-unsafe-context-exn
|
||||
(lambda () (nta-eval '(dispatch-start 'foo)))))))
|
||||
(let-values ([(go nta-eval)
|
||||
(make-module-eval
|
||||
(module nta mzscheme
|
||||
(provide non-tail-apply)
|
||||
|
||||
(define (non-tail-apply f . args)
|
||||
(let ([result (apply f args)])
|
||||
(printf "result = ~s~n" result)
|
||||
result))))])
|
||||
(nta-eval '(module m09 "../lang.ss"
|
||||
(require nta)
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(non-tail-apply (lambda (x) (let/cc k (k x))) 7))))
|
||||
|
||||
(nta-eval '(require m09))
|
||||
|
||||
(assert-true (catch-unsafe-context-exn
|
||||
(lambda () (nta-eval '(dispatch-start 'foo)))))))
|
||||
|
||||
(make-test-case
|
||||
"sanity-check: capture continuation from safe version of context"
|
||||
|
||||
(let-values ([(go m10-eval)
|
||||
(make-module-eval
|
||||
(module m10 "../lang.ss"
|
||||
(provide start)
|
||||
(define (nta f arg)
|
||||
(let ([result (f arg)])
|
||||
(printf "result = ~s~n" result)
|
||||
result))
|
||||
(define (start ignore)
|
||||
(nta (lambda (x) (let/cc k (k x))) 7))))])
|
||||
(make-module-eval
|
||||
(module m10 "../lang.ss"
|
||||
(provide start)
|
||||
(define (nta f arg)
|
||||
(let ([result (f arg)])
|
||||
(printf "result = ~s~n" result)
|
||||
result))
|
||||
(define (start ignore)
|
||||
(nta (lambda (x) (let/cc k (k x))) 7))))])
|
||||
(go)
|
||||
(assert = 7 (m10-eval '(dispatch-start 'foo)))))
|
||||
|
||||
|
|
@ -409,13 +367,13 @@
|
|||
"attempt continuation capture from standard call to map"
|
||||
|
||||
(let-values ([(go m11-eval)
|
||||
(make-module-eval
|
||||
(module m11 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(map
|
||||
(lambda (x) (let/cc k k))
|
||||
(list 1 2 3)))))])
|
||||
(make-module-eval
|
||||
(module m11 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(map
|
||||
(lambda (x) (let/cc k k))
|
||||
(list 1 2 3)))))])
|
||||
(go)
|
||||
(assert-true (catch-unsafe-context-exn
|
||||
(lambda () (m11-eval '(dispatch-start 'foo)))))))
|
||||
|
|
@ -424,70 +382,70 @@
|
|||
;; should be just fine.
|
||||
; XXX Weird
|
||||
#;(make-test-case
|
||||
"continuation capture from tail position of untranslated procedure"
|
||||
|
||||
(let ([ta-eval
|
||||
(make-module-eval
|
||||
(module ta mzscheme
|
||||
(provide tail-apply)
|
||||
|
||||
(define (tail-apply f . args)
|
||||
(apply f args))))])
|
||||
"continuation capture from tail position of untranslated procedure"
|
||||
|
||||
(ta-eval '(module m12 "../lang.ss"
|
||||
(require ta)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ initial
|
||||
(tail-apply (lambda (x) (let/cc k (k x))) 1)))))
|
||||
|
||||
(ta-eval '(require m12))
|
||||
|
||||
(assert = 2 (ta-eval '(dispatch-start 1)))))
|
||||
(let ([ta-eval
|
||||
(make-module-eval
|
||||
(module ta mzscheme
|
||||
(provide tail-apply)
|
||||
|
||||
(define (tail-apply f . args)
|
||||
(apply f args))))])
|
||||
|
||||
(ta-eval '(module m12 "../lang.ss"
|
||||
(require ta)
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(+ initial
|
||||
(tail-apply (lambda (x) (let/cc k (k x))) 1)))))
|
||||
|
||||
(ta-eval '(require m12))
|
||||
|
||||
(assert = 2 (ta-eval '(dispatch-start 1)))))
|
||||
|
||||
(make-test-case
|
||||
"attempt send/suspend from standard call to map"
|
||||
|
||||
(let-values ([(go m13-eval)
|
||||
(make-module-eval
|
||||
(module m11 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(map
|
||||
(lambda (n) (send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "n = ~s~n" n)])
|
||||
k))))
|
||||
(list 1 2 3)))))])
|
||||
(make-module-eval
|
||||
(module m11 "../lang.ss"
|
||||
(provide start)
|
||||
(define (start initial)
|
||||
(map
|
||||
(lambda (n) (send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "n = ~s~n" n)])
|
||||
k))))
|
||||
(list 1 2 3)))))])
|
||||
(go)
|
||||
(assert-true (catch-unsafe-context-exn
|
||||
(lambda () (m13-eval '(dispatch-start 'foo)))))))
|
||||
|
||||
; XXX Weird
|
||||
#;(make-test-case
|
||||
"attempt send/suspend from tail position of untranslated procedure"
|
||||
|
||||
(let-values ([(go ta-eval)
|
||||
(make-module-eval
|
||||
(module ta mzscheme
|
||||
(provide tail-apply)
|
||||
|
||||
(define (tail-apply f . args)
|
||||
(apply f args))))])
|
||||
"attempt send/suspend from tail position of untranslated procedure"
|
||||
|
||||
(ta-eval '(module m14 "../lang.ss"
|
||||
(require ta)
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(+ 1 (tail-apply
|
||||
(lambda (n)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "n = ~s~n" n)])
|
||||
k))))) 7)))))
|
||||
(ta-eval '(require m14))
|
||||
|
||||
(let ([k0 (ta-eval '(dispatch-start 'foo))])
|
||||
(assert = 3 (ta-eval `(dispatch (list ,k0 2))))
|
||||
(assert = 0 (ta-eval `(dispatch (list ,k0 -1)))))))))))
|
||||
(let-values ([(go ta-eval)
|
||||
(make-module-eval
|
||||
(module ta mzscheme
|
||||
(provide tail-apply)
|
||||
|
||||
(define (tail-apply f . args)
|
||||
(apply f args))))])
|
||||
|
||||
(ta-eval '(module m14 "../lang.ss"
|
||||
(require ta)
|
||||
(provide start)
|
||||
(define (start ignore)
|
||||
(+ 1 (tail-apply
|
||||
(lambda (n)
|
||||
(cadr
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(let ([ignore (printf "n = ~s~n" n)])
|
||||
k))))) 7)))))
|
||||
(ta-eval '(require m14))
|
||||
|
||||
(let ([k0 (ta-eval '(dispatch-start 'foo))])
|
||||
(assert = 3 (ta-eval `(dispatch (list ,k0 2))))
|
||||
(assert = 0 (ta-eval `(dispatch (list ,k0 -1)))))))))))
|
||||
|
|
@ -2,27 +2,30 @@
|
|||
(provide make-module-eval
|
||||
make-eval/mod-path)
|
||||
|
||||
(define (go ns)
|
||||
(lambda ()
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval '(abort/cc
|
||||
(with-continuation-mark safe-call? '(#t start)
|
||||
(start
|
||||
(with-continuation-mark the-cont-key start
|
||||
(start-interaction
|
||||
(lambda (k*v)
|
||||
(lambda (k*v)
|
||||
((car k*v) k*v))))))))))))
|
||||
|
||||
(define-syntax (make-module-eval m-expr)
|
||||
(syntax-case m-expr (module)
|
||||
[(_ (module m-id . rest))
|
||||
#'(let ([ns (make-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval '(require "../abort-resume.ss"
|
||||
(eval '(require (lib "abort-resume.ss" "web-server" "prototype-web-server")
|
||||
(lib "serialize.ss")))
|
||||
(eval '(module m-id . rest))
|
||||
(eval '(require m-id)))
|
||||
|
||||
(values
|
||||
(lambda ()
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval '(abort/cc
|
||||
(with-continuation-mark safe-call? '(#t start)
|
||||
(start
|
||||
(with-continuation-mark the-cont-key start
|
||||
(start-interaction
|
||||
(lambda (k*v)
|
||||
(lambda (k*v)
|
||||
((car k*v) k*v)))))))))))
|
||||
(go ns)
|
||||
(lambda (s-expr)
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval s-expr)))))]
|
||||
|
|
@ -32,9 +35,10 @@
|
|||
(define (make-eval/mod-path pth)
|
||||
(let ([ns (make-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval `(require (lib "client.ss" "web-server" "prototype-web-server")
|
||||
(eval `(require (lib "abort-resume.ss" "web-server" "prototype-web-server")
|
||||
(lib "serialize.ss")
|
||||
(file ,pth))))
|
||||
(lambda (expr)
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval expr))))))
|
||||
(values (go ns)
|
||||
(lambda (expr)
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval expr)))))))
|
||||
|
|
@ -48,29 +48,32 @@
|
|||
|
||||
(make-test-case
|
||||
"compose url-parts and recover-serial (1)"
|
||||
(let* ([ev (make-eval/mod-path "modules/mm00.ss")]
|
||||
[k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
|
||||
`(file "modules/mm00.ss"))]
|
||||
[k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
|
||||
`(file "modules/mm00.ss"))]
|
||||
[k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
|
||||
`(file "modules/mm00.ss"))])
|
||||
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))
|
||||
(let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")])
|
||||
(go)
|
||||
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
|
||||
`(file "modules/mm00.ss"))]
|
||||
[k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
|
||||
`(file "modules/mm00.ss"))]
|
||||
[k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
|
||||
`(file "modules/mm00.ss"))])
|
||||
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))
|
||||
|
||||
(make-test-case
|
||||
"compose url-parts and recover-serial (2)"
|
||||
(let* ([ev (make-eval/mod-path "modules/mm01.ss")]
|
||||
[k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
|
||||
`(file "modules/mm01.ss"))])
|
||||
(assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7)))))))
|
||||
(let-values ([(go ev) (make-eval/mod-path "modules/mm01.ss")])
|
||||
(go)
|
||||
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo)))
|
||||
`(file "modules/mm01.ss"))])
|
||||
(assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7))))))))
|
||||
|
||||
(make-test-case
|
||||
"compose stuff-url and unstuff-url and recover the serial"
|
||||
(let* ([ev (make-eval/mod-path "modules/mm00.ss")]
|
||||
[k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo)))
|
||||
uri0 `(file "modules/mm00.ss"))]
|
||||
[k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
|
||||
uri0 `(file "modules/mm00.ss"))]
|
||||
[k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
|
||||
uri0 `(file "modules/mm00.ss"))])
|
||||
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))))
|
||||
(let-values ([(go ev) (make-eval/mod-path "modules/mm00.ss")])
|
||||
(go)
|
||||
(let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo)))
|
||||
uri0 `(file "modules/mm00.ss"))]
|
||||
[k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
|
||||
uri0 `(file "modules/mm00.ss"))]
|
||||
[k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
|
||||
uri0 `(file "modules/mm00.ss"))])
|
||||
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))))))
|
||||
|
|
@ -1,11 +1,13 @@
|
|||
(module suite mzscheme
|
||||
(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
|
||||
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 1))
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
"persistent-close-tests.ss"
|
||||
"test-normalizer.ss"
|
||||
"closure-tests.ss"
|
||||
"labels-tests.ss"
|
||||
"lang-tests.ss"
|
||||
"certify-tests.ss"
|
||||
"stuff-url-tests.ss")
|
||||
|
||||
(test/graphical-ui
|
||||
|
|
@ -17,4 +19,5 @@
|
|||
closure-tests-suite
|
||||
labels-tests-suite
|
||||
lang-suite
|
||||
certify-suite
|
||||
)))
|
||||
Loading…
Reference in New Issue
Block a user