diff --git a/compile.rkt b/compile.rkt index a8f074f..706b0de 100644 --- a/compile.rkt +++ b/compile.rkt @@ -65,6 +65,9 @@ [(Seq? exp) (apply append (map (lambda: ([e : Expression]) (loop e cenv)) (Seq-actions exp)))] + [(Splice? exp) + (apply append (map (lambda: ([e : Expression]) (loop e cenv)) + (Splice-actions exp)))] [(App? exp) (let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?)) cenv)]) @@ -135,6 +138,11 @@ cenv target linkage)] + [(Splice? exp) + (compile-splice (Splice-actions exp) + cenv + target + linkage)] [(App? exp) (compile-application exp cenv target linkage)] [(Let1? exp) @@ -292,6 +300,26 @@ (compile-sequence (rest-exps seq) cenv target linkage)))) +(: compile-splice ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Wrap a continuation prompt around each of the expressions. +(define (compile-splice seq cenv target linkage) + (cond [(last-exp? seq) + (end-with-linkage + linkage + cenv + (append-instruction-sequences + #;(make-instruction-sequence `(,(make-PushPrompt))) + (compile (first-exp seq) cenv target next-linkage) + #;(make-instruction-sequence `(,(make-PushPrompt)))))] + [else + (append-instruction-sequences + #;(make-instruction-sequence `(,(make-PushPrompt))) + (compile (first-exp seq) cenv target next-linkage) + #;(make-instruction-sequence `(,(make-PushPrompt))) + (compile-splice (rest-exps seq) cenv target linkage))])) + + + (: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Write out code for lambda expressions. ;; The lambda will close over the free variables. @@ -1196,6 +1224,11 @@ (make-Seq (map (lambda: ([action : Expression]) (adjust-expression-depth action n skip)) (Seq-actions exp)))] + + [(Splice? exp) + (make-Splice (map (lambda: ([action : Expression]) + (adjust-expression-depth action n skip)) + (Splice-actions exp)))] [(App? exp) (make-App (adjust-expression-depth (App-operator exp) n diff --git a/expression-structs.rkt b/expression-structs.rkt index 53102b7..20275de 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -8,7 +8,7 @@ (define-type Expression (U Top Constant ToplevelRef LocalRef ToplevelSet - Branch Lam Seq App + Branch Lam Seq Splice App Let1 LetVoid LetRec @@ -44,6 +44,7 @@ [entry-label : Symbol]) #:transparent) (define-struct: Seq ([actions : (Listof Expression)]) #:transparent) +(define-struct: Splice ([actions : (Listof Expression)]) #:transparent) (define-struct: App ([operator : Expression] [operands : (Listof Expression)]) #:transparent) diff --git a/parse.rkt b/parse.rkt index 9a032b0..426ad58 100644 --- a/parse.rkt +++ b/parse.rkt @@ -14,7 +14,7 @@ (define (-parse exp) (let* ([prefix (construct-the-prefix exp)]) - (make-Top prefix (parse exp (extend-lexical-environment '() prefix))))) + (make-Top prefix (parse exp (extend-lexical-environment '() prefix) #t)))) @@ -72,7 +72,7 @@ ;; parse: Any ParseTimeEnvironment -> Expression ;; Compile an expression. -(define (parse exp cenv) +(define (parse exp cenv at-toplevel?) (cond [(self-evaluating? exp) (make-Constant exp)] @@ -100,30 +100,30 @@ (EnvPrefixReference-pos address) (definition-variable exp) (parameterize ([current-defined-name (definition-variable exp)]) - (parse (definition-value exp) cenv)))]))] + (parse (definition-value exp) cenv #f)))]))] [(if? exp) - (make-Branch (parse (if-predicate exp) cenv) - (parse (if-consequent exp) cenv) - (parse (if-alternative exp) cenv))] + (make-Branch (parse (if-predicate exp) cenv #f) + (parse (if-consequent exp) cenv #f) + (parse (if-alternative exp) cenv #f))] [(cond? exp) - (parse (desugar-cond exp) cenv)] + (parse (desugar-cond exp) cenv #f)] [(lambda? exp) (parse-lambda exp cenv)] [(begin? exp) (let ([actions (map (lambda (e) - (parse e cenv)) + (parse e cenv at-toplevel?)) (begin-actions exp))]) - (seq actions))] + ((if at-toplevel? make-Splice seq) actions))] [(named-let? exp) - (parse (desugar-named-let exp) cenv)] + (parse (desugar-named-let exp) cenv #f)] [(let*? exp) - (parse (desugar-let* exp) cenv)] + (parse (desugar-let* exp) cenv #f)] [(let? exp) (parse-let exp cenv)] @@ -138,21 +138,21 @@ (make-Seq (list (cond [(EnvLexicalReference? address) (make-InstallValue (EnvLexicalReference-depth address) - (parse (set!-value exp) cenv) + (parse (set!-value exp) cenv #f) #t)] [(EnvPrefixReference? address) (make-ToplevelSet (EnvPrefixReference-depth address) (EnvPrefixReference-pos address) (definition-variable exp) - (parse (set!-value exp) cenv))]) + (parse (set!-value exp) cenv #f))]) (make-Constant (void)))))] ;; Remember, this needs to be the last case. [(application? exp) (let ([cenv-with-scratch-space (extend-lexical-environment/placeholders cenv (length (operands exp)))]) - (make-App (parse (operator exp) cenv-with-scratch-space) - (map (lambda (rand) (parse rand cenv-with-scratch-space)) + (make-App (parse (operator exp) cenv-with-scratch-space #f) + (map (lambda (rand) (parse rand cenv-with-scratch-space #f)) (operands exp))))] [else (error 'compile "Unknown expression type ~e" exp)])) @@ -180,7 +180,7 @@ (make-BoxEnv (env-reference-depth (find-variable a-mutated-param body-cenv)) code)) (seq (map (lambda (b) - (parse b body-cenv)) + (parse b body-cenv #f)) (lambda-body exp))) mutated-parameters)]) (make-Lam (current-defined-name) @@ -441,16 +441,17 @@ [body (let-body exp)]) (cond [(= 0 (length vars)) - (parse `(begin ,@body) cenv)] + (parse `(begin ,@body) cenv #f)] [(= 1 (length vars)) (let* ([mutated? (and (member (first vars) (find-mutated-names `(begin ,@body))) #t)] [let-body (parse `(begin ,@body) (extend-lexical-environment/names cenv (list (first vars)) - (list mutated?)))]) + (list mutated?)) + #f)]) (make-Let1 (parameterize ([current-defined-name (first vars)]) - (parse (car rhss) (extend-lexical-environment/placeholders cenv 1))) + (parse (car rhss) (extend-lexical-environment/placeholders cenv 1) #f)) (if mutated? (make-BoxEnv 0 let-body) let-body)))] @@ -463,7 +464,7 @@ (map (lambda (var rhs index) (make-InstallValue index (parameterize ([current-defined-name var]) - (parse rhs rhs-cenv)) + (parse rhs rhs-cenv #f)) any-mutated?)) vars rhss @@ -473,7 +474,8 @@ cenv vars (build-list (length vars) (lambda (i) - any-mutated?))))))) + any-mutated?))) + #f)))) any-mutated?))]))) @@ -485,7 +487,7 @@ [n (length vars)]) (cond [(= 0 (length vars)) - (parse `(begin ,@body) cenv)] + (parse `(begin ,@body) cenv #f)] [(and (andmap lambda? rhss) (empty? (list-intersection vars @@ -498,10 +500,10 @@ ;; Install them in reverse order, so that the closure shell for the last element ;; in procs is at stack position 0. (make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name]) - (parse rhs new-cenv))) + (parse rhs new-cenv #f))) rhss vars) - (parse `(begin ,@body) new-cenv)))] + (parse `(begin ,@body) new-cenv #f)))] [else (let ([new-cenv (extend-lexical-environment/boxed-names cenv (reverse vars))]) (make-LetVoid (length vars) @@ -509,12 +511,12 @@ (map (lambda (var rhs index) (make-InstallValue (- n 1 index) (parameterize ([current-defined-name var]) - (parse rhs new-cenv)) + (parse rhs new-cenv #f)) #t)) vars rhss (build-list (length rhss) (lambda (i) i))) - (list (parse `(begin ,@body) new-cenv)))) + (list (parse `(begin ,@body) new-cenv #f)))) #t))]))) diff --git a/test-compiler.rkt b/test-compiler.rkt index a056a13..f376a54 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -788,6 +788,83 @@ +(test '(begin + (define (make-gen gen) + (let ([cont (box #f)]) + (lambda () + (call/cc (lambda (caller) + (if (unbox cont) + ((unbox cont) caller) + (gen (lambda (v) + (call/cc (lambda (gen-k) + (begin + (set-box! cont gen-k) + (caller v)))))))))))) + + (define g1 (make-gen (lambda (return) + (return "a") + (return "b") + (return "c")))) + + (list (g1))) + (list "a")) + + + +;; FIXME: this test is failing. I think we need prompts to delimit +;; the continuation capture. +#;(test '(begin + (define (make-gen gen) + (let ([cont (box #f)]) + (lambda () + (call/cc (lambda (caller) + (if (unbox cont) + ((unbox cont) caller) + (gen (lambda (v) + (call/cc (lambda (gen-k) + (begin + (set-box! cont gen-k) + (caller v)))))))))))) + + (define g1 (make-gen (lambda (return) + (return "a") + (return "b") + (return "c")))) + + (g1) + (g1)) + "b") + + + +;; FIXME: this test is failing. I think we need prompts to delimit +;; the continuation capture. +#;(test '(begin + (define (make-gen gen) + (let ([cont (box #f)]) + (lambda () + (call/cc (lambda (caller) + (if (unbox cont) + ((unbox cont) caller) + (gen (lambda (v) + (call/cc (lambda (gen-k) + (begin + (set-box! cont gen-k) + (caller v)))))))))))) + + (define g1 (make-gen (lambda (return) + (return "a") + (return "b") + (return "c")))) + + (displayln (g1)) + (displayln (g1)) + (displayln (g1))) + "a\nb\nc\n") + + + + #;(test (read (open-input-file "tests/conform/program0.sch")) diff --git a/test-parse.rkt b/test-parse.rkt index bea88aa..2b6b83c 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -42,7 +42,7 @@ (test (parse '(begin hello world)) (make-Top (make-Prefix '(hello world)) - (make-Seq (list (make-ToplevelRef 0 0) + (make-Splice (list (make-ToplevelRef 0 0) (make-ToplevelRef 0 1))))) (test (parse '(define x y)) @@ -52,8 +52,8 @@ (test (parse '(begin (define x 42) (define y x))) (make-Top (make-Prefix '(x y)) - (make-Seq (list (make-ToplevelSet 0 0 'x (make-Constant 42)) - (make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0)))))) + (make-Splice (list (make-ToplevelSet 0 0 'x (make-Constant 42)) + (make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0)))))) (test (parse '(if x y z)) (make-Top (make-Prefix '(x y z)) @@ -402,7 +402,7 @@ (list a b))) (make-Top (make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!)) - (make-Seq + (make-Splice (list (make-ToplevelSet 0 0 'a (make-Constant '(hello))) (make-ToplevelSet 0 1 'b (make-Constant '(world)))