Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
487 lines (431 sloc) 22.9 KB
#lang eopl
;; Exercise 6.26 [★★] A continuation variable introduced by cps-of-exps will only occur once in the continuation.
;; Modify make-send-to-cont so that instead of generating
;;
;; let var1 = simp1
;; in T
;;
;; as in exercise 6.22, it generates T[simp1/var1], where the notation E1[E2/var] means expression E1 with every free
;; occurrence of the variable var replaced by E2.
;; CPS-IN grammar.
(define the-lexical-spec
'([whitespace (whitespace) skip]
[comment ("%" (arbno (not #\newline))) skip]
[identifier (letter (arbno (or letter digit "_" "-" "?"))) symbol]
[number (digit (arbno digit)) number]
[number ("-" digit (arbno digit)) number]))
(define the-grammar
'([program (expression) a-program]
[expression (number) const-exp]
[expression ("-" "(" expression "," expression ")") diff-exp]
[expression ("+" "(" (separated-list expression ",") ")") sum-exp]
[expression ("zero?" "(" expression ")") zero?-exp]
[expression ("if" expression "then" expression "else" expression) if-exp]
[expression ("letrec" (arbno identifier "(" (arbno identifier) ")" "=" expression) "in" expression) letrec-exp]
[expression (identifier) var-exp]
[expression ("let" identifier "=" expression "in" expression) let-exp]
[expression ("proc" "(" (arbno identifier) ")" expression) proc-exp]
[expression ("(" expression (arbno expression) ")") call-exp]))
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define scan&parse (sllgen:make-string-parser the-lexical-spec the-grammar))
;; CPS-OUT grammar.
(define cps-out-lexical-spec
'([whitespace (whitespace) skip]
[comment ("%" (arbno (not #\newline))) skip]
[identifier (letter (arbno (or letter digit "_" "-" "?"))) symbol]
[number (digit (arbno digit)) number]
[number ("-" digit (arbno digit)) number]))
(define cps-out-grammar
'([cps-out-program (tfexp) cps-a-program]
[simple-expression (number) cps-const-exp]
[simple-expression (identifier) cps-var-exp]
[simple-expression ("-" "(" simple-expression "," simple-expression ")") cps-diff-exp]
[simple-expression ("zero?" "(" simple-expression ")") cps-zero?-exp]
[simple-expression ("+" "(" (separated-list simple-expression ",") ")") cps-sum-exp]
[simple-expression ("proc" "(" (arbno identifier) ")" tfexp) cps-proc-exp]
[tfexp (simple-expression) simple-exp->exp]
[tfexp ("let" identifier "=" simple-expression "in" tfexp) cps-let-exp]
[tfexp ("letrec" (arbno identifier "(" (arbno identifier) ")" "=" tfexp) "in" tfexp) cps-letrec-exp]
[tfexp ("if" simple-expression "then" tfexp "else" tfexp) cps-if-exp]
[tfexp ("(" simple-expression (arbno simple-expression) ")") cps-call-exp]))
(sllgen:make-define-datatypes cps-out-lexical-spec cps-out-grammar)
;; Transformer.
(define list-set
(lambda (lst n val)
(cond [(null? lst) (eopl:error 'list-set "ran off end")]
[(zero? n) (cons val (cdr lst))]
[else (cons (car lst) (list-set (cdr lst) (- n 1) val))])))
(define fresh-identifier
(let ([sn 0])
(lambda (identifier)
(set! sn (+ sn 1))
(string->symbol (string-append (symbol->string identifier) "%" (number->string sn))))))
(define all-simple?
(lambda (exps)
(if (null? exps)
#t
(and (inp-exp-simple? (car exps))
(all-simple? (cdr exps))))))
(define inp-exp-simple?
(lambda (exp)
(cases expression exp
[const-exp (num) #t]
[var-exp (var) #t]
[diff-exp (exp1 exp2) (and (inp-exp-simple? exp1) (inp-exp-simple? exp2))]
[zero?-exp (exp1) (inp-exp-simple? exp1)]
[proc-exp (ids exp) #t]
[sum-exp (exps) (all-simple? exps)]
[else #f])))
(define replace-one
(lambda (replacer lst success failure)
(let loop ([result '()]
[lst lst])
(if (null? lst)
(failure)
(let* ([head (car lst)]
[tail (cdr lst)]
[replace-result (replacer head)])
(if replace-result
(success (append (reverse result) (cons replace-result tail)))
(loop (cons head result)
tail)))))))
(define replace-free-var-simple-exp
(lambda (exp var val success failure)
(let loop ([exp exp]
[success success]
[failure failure])
(cases simple-expression exp
[cps-const-exp (exp1) (failure)]
[cps-var-exp (var1) (if (eqv? var1 var)
(success val)
(failure))]
[cps-diff-exp (exp1 exp2) (loop exp1
(lambda (result1)
(success (cps-diff-exp result1 exp2)))
(lambda ()
(loop exp2
(lambda (result2)
(success (cps-diff-exp exp1 result2)))
failure)))]
[cps-zero?-exp (exp1) (loop exp1
(lambda (result1)
(success (cps-zero?-exp result1)))
failure)]
[cps-sum-exp (exps) (replace-one (lambda (exp)
(loop exp var val)
(lambda (result)
result)
(lambda ()
#f))
exps
(lambda (results)
(success (cps-sum-exp results)))
failure)]
[cps-proc-exp (vars body) (replace-free-var-tfexp body
var
val
(lambda (result)
(success (cps-proc-exp vars result)))
failure)]))))
(define replace-free-var-tfexp
(lambda (exp var val success failure)
(let loop ([exp exp]
[success success]
[failure failure])
(cases tfexp exp
[simple-exp->exp (exp1) (replace-free-var-simple-exp exp1
var
val
(lambda (result)
(success (simple-exp->exp result)))
failure)]
[cps-let-exp (var1 exp1 body) (replace-free-var-simple-exp exp1
var
val
(lambda (result1)
(success (cps-let-exp var1 result1 body)))
(lambda ()
(loop body
(lambda (result2)
(success (cps-let-exp var1 exp1 result2)))
failure)))]
[cps-letrec-exp (p-names b-varss p-bodies letrec-body) (replace-one (lambda (exp)
(loop exp
(lambda (result)
result)
(lambda ()
#f)))
p-bodies
(lambda (results)
(success (cps-letrec-exp p-names
b-varss
results
letrec-body)))
(lambda ()
(loop letrec-body
(lambda (result)
(success (cps-letrec-exp p-names
b-varss
p-bodies
result)))
failure)))]
[cps-if-exp (simple1 body1 body2) (replace-free-var-simple-exp simple1
var
val
(lambda (result)
(success (cps-if-exp result body1 body2)))
(lambda ()
(loop body1
(lambda (result)
(success (cps-if-exp simple1
result
body2)))
(lambda ()
(loop body2
(lambda (result)
(success (cps-if-exp simple1
body1
result)))
failure)))))]
[cps-call-exp (rator rands)
(replace-free-var-simple-exp rator
var
val
(lambda (result)
(success (cps-call-exp result rands)))
(lambda ()
(replace-one (lambda (rand)
(replace-free-var-simple-exp rand
var
val
(lambda (result)
result)
failure))
rands
(lambda (result)
(success (cps-call-exp rator result)))
failure)))]))))
(define make-send-to-cont
(lambda (cont bexp)
(cases simple-expression cont
[cps-proc-exp (vars body) (let ([var (car vars)])
(replace-free-var-tfexp body
var
bexp
(lambda (result)
result)
(lambda ()
(eopl:error 'replace-free-var-tfexp
"Variable ~s not found in ~s!"
var
body))))]
[else (cps-call-exp cont (list bexp))])))
(define cps-of-zero?-exp
(lambda (exp1 k-exp)
(cps-of-exps (list exp1)
(lambda (new-rands)
(make-send-to-cont k-exp (cps-zero?-exp (car new-rands)))))))
(define cps-of-sum-exp
(lambda (exps k-exp)
(cps-of-exps exps
(lambda (new-rands)
(make-send-to-cont k-exp (cps-sum-exp new-rands))))))
(define cps-of-diff-exp
(lambda (exp1 exp2 k-exp)
(cps-of-exps (list exp1 exp2)
(lambda (new-rands)
(make-send-to-cont k-exp (cps-diff-exp (car new-rands) (cadr new-rands)))))))
(define cps-of-if-exp
(lambda (exp1 exp2 exp3 k-exp)
(cps-of-exps (list exp1)
(lambda (new-rands)
(cps-if-exp (car new-rands) (cps-of-exp exp2 k-exp) (cps-of-exp exp3 k-exp))))))
(define cps-of-let-exp
(lambda (id rhs body k-exp)
(cps-of-exps (list rhs)
(lambda (new-rands)
(cps-let-exp id (car new-rands) (cps-of-exp body k-exp))))))
(define cps-of-letrec-exp
(lambda (proc-names idss proc-bodies body k-exp)
(cps-letrec-exp proc-names
(map (lambda (ids)
(append ids (list 'k%00)))
idss)
(map (lambda (exp)
(cps-of-exp exp (cps-var-exp 'k%00)))
proc-bodies)
(cps-of-exp body k-exp))))
(define cps-of-call-exp
(lambda (rator rands k-exp)
(cps-of-exps (cons rator rands)
(lambda (new-rands)
(cps-call-exp (car new-rands) (append (cdr new-rands) (list k-exp)))))))
(define report-invalid-exp-to-cps-of-simple-exp
(lambda (exp)
(eopl:error 'cps-of-simple-exp "non-simple expression to cps-of-simple-exp: ~s" exp)))
(define cps-of-simple-exp
(lambda (exp)
(cases expression exp
[const-exp (num) (cps-const-exp num)]
[var-exp (var) (cps-var-exp var)]
[diff-exp (exp1 exp2) (cps-diff-exp (cps-of-simple-exp exp1) (cps-of-simple-exp exp2))]
[zero?-exp (exp1) (cps-zero?-exp (cps-of-simple-exp exp1))]
[proc-exp (ids exp) (cps-proc-exp (append ids (list 'k%00)) (cps-of-exp exp (cps-var-exp 'k%00)))]
[sum-exp (exps) (cps-sum-exp (map cps-of-simple-exp exps))]
[else (report-invalid-exp-to-cps-of-simple-exp exp)])))
(define cps-of-exp
(lambda (exp cont)
(cases expression exp
[const-exp (num) (make-send-to-cont cont (cps-const-exp num))]
[var-exp (var) (make-send-to-cont cont (cps-var-exp var))]
[proc-exp (vars body) (make-send-to-cont cont
(cps-proc-exp (append vars (list 'k%00))
(cps-of-exp body (cps-var-exp 'k%00))))]
[zero?-exp (exp1) (cps-of-zero?-exp exp1 cont)]
[diff-exp (exp1 exp2) (cps-of-diff-exp exp1 exp2 cont)]
[sum-exp (exps) (cps-of-sum-exp exps cont)]
[if-exp (exp1 exp2 exp3) (cps-of-if-exp exp1 exp2 exp3 cont)]
[let-exp (var exp1 body) (cps-of-let-exp var exp1 body cont)]
[letrec-exp (ids bidss proc-bodies body) (cps-of-letrec-exp ids bidss proc-bodies body cont)]
[call-exp (rator rands) (cps-of-call-exp rator rands cont)])))
(define cps-of-exps
(lambda (exps builder)
(define list-index
(lambda (pred lst)
(cond [(null? lst) #f]
[(pred (car lst)) 0]
[(list-index pred (cdr lst)) => (lambda (n)
(+ n 1))]
[else #f])))
(let cps-of-rest ([exps exps])
(let ([pos (list-index (lambda (exp)
(not (inp-exp-simple? exp)))
exps)])
(if (not pos)
(builder (map cps-of-simple-exp exps))
(let ([var (fresh-identifier 'var)])
(cps-of-exp (list-ref exps pos)
(cps-proc-exp (list var) (cps-of-rest (list-set exps pos (var-exp var)))))))))))
(define cps-of-program
(lambda (pgm)
(cases program pgm
[a-program (exp1) (cps-a-program (cps-of-exps (list exp1)
(lambda (new-args)
(simple-exp->exp (car new-args)))))])))
;; Data structures - expressed values.
(define-datatype proc proc?
[procedure [vars (list-of symbol?)]
[body tfexp?]
[env environment?]])
(define-datatype expval expval?
[num-val [value number?]]
[bool-val [boolean boolean?]]
[proc-val [proc proc?]])
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s" variant value)))
(define expval->num
(lambda (v)
(cases expval v
[num-val (num) num]
[else (expval-extractor-error 'num v)])))
(define expval->bool
(lambda (v)
(cases expval v
[bool-val (bool) bool]
[else (expval-extractor-error 'bool v)])))
(define expval->proc
(lambda (v)
(cases expval v
[proc-val (proc) proc]
[else (expval-extractor-error 'proc v)])))
;; Data structures - environment.
(define empty-env
(lambda ()
'()))
(define extend-env*
(lambda (syms vals old-env)
(cons (list 'let syms vals) old-env)))
(define extend-env-rec**
(lambda (p-names b-varss p-bodies saved-env)
(cons (list 'letrec p-names b-varss p-bodies) saved-env)))
(define environment?
(list-of (lambda (p)
(and (pair? p) (or (eqv? (car p) 'let) (eqv? (car p) 'letrec))))))
(define apply-env
(lambda (env search-sym)
(define list-index
(lambda (sym los)
(let loop ([pos 0]
[los los])
(cond [(null? los) #f]
[(eqv? sym (car los)) pos]
[else (loop (+ pos 1) (cdr los))]))))
(if (null? env)
(eopl:error 'apply-env "No binding for ~s" search-sym)
(let* ([binding (car env)]
[saved-env (cdr env)])
(let ([pos (list-index search-sym (cadr binding))])
(if pos
(case (car binding)
[(let) (list-ref (caddr binding) pos)]
[(letrec) (let ([bvars (caddr binding)]
[bodies (cadddr binding)])
(proc-val (procedure (list-ref bvars pos) (list-ref bodies pos) env)))])
(apply-env saved-env search-sym)))))))
;; Data structures - continuation.
(define-datatype continuation continuation?
[end-cont])
;; Interpreter.
(define apply-cont
(lambda (cont val)
(cases continuation cont
[end-cont () val])))
(define apply-procedure/k
(lambda (proc1 args cont)
(cases proc proc1
[procedure (vars body saved-env) (value-of/k body (extend-env* vars args saved-env) cont)])))
(define value-of-simple-exp
(lambda (exp env)
(cases simple-expression exp
[cps-const-exp (num) (num-val num)]
[cps-var-exp (var) (apply-env env var)]
[cps-diff-exp (exp1 exp2) (let ([val1 (expval->num (value-of-simple-exp exp1 env))]
[val2 (expval->num (value-of-simple-exp exp2 env))])
(num-val (- val1 val2)))]
[cps-zero?-exp (exp1) (bool-val (zero? (expval->num (value-of-simple-exp exp1 env))))]
[cps-sum-exp (exps) (let ([nums (map (lambda (exp)
(expval->num (value-of-simple-exp exp env)))
exps)])
(num-val (let sum-loop ([nums nums])
(if (null? nums)
0
(+ (car nums) (sum-loop (cdr nums)))))))]
[cps-proc-exp (vars body) (proc-val (procedure vars body env))])))
(define value-of/k
(lambda (exp env cont)
(cases tfexp exp
[simple-exp->exp (simple) (apply-cont cont (value-of-simple-exp simple env))]
[cps-let-exp (var rhs body) (let ([val (value-of-simple-exp rhs env)])
(value-of/k body (extend-env* (list var) (list val) env) cont))]
[cps-letrec-exp (p-names b-varss p-bodies letrec-body) (value-of/k letrec-body
(extend-env-rec** p-names b-varss p-bodies env)
cont)]
[cps-if-exp (simple1 body1 body2) (if (expval->bool (value-of-simple-exp simple1 env))
(value-of/k body1 env cont)
(value-of/k body2 env cont))]
[cps-call-exp (rator rands) (let ([rator-proc (expval->proc (value-of-simple-exp rator env))]
[rand-vals (map (lambda (simple)
(value-of-simple-exp simple env))
rands)])
(apply-procedure/k rator-proc rand-vals cont))])))
(define value-of-program
(lambda (pgm)
(cases cps-out-program pgm
[cps-a-program (exp1) (value-of/k exp1 (empty-env) (end-cont))])))
;; Interface.
(define run
(lambda (string)
(let ([cpsed-pgm (cps-of-program (scan&parse string))])
(value-of-program cpsed-pgm))))
(provide bool-val num-val run)