;;; Sample solutions for MP9 Task 1, 2, 3. ============= This solution was obtained by modifying the simple-throw interpreter. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lang.scm ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; a simple language (module lang (lib "eopl.ss" "eopl") (require "drscheme-init.scm") (provide (all-defined)) ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; (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 ((arbno definition) expression) a-program) (definition ("define" identifier "=" "proc" "(" (arbno identifier) ")" expression) proc-definition) (expression (number) lit-exp) (expression (identifier) var-exp) (expression (binop "(" expression "," expression ")") binop-exp) (expression ("if" expression "then" expression "else" expression) if-exp) (expression ("(" expression (arbno expression) ")") call-exp) (expression ("let" (arbno identifier "=" expression) "in" expression) let-exp) (expression ("return" expression) return-exp) (binop ("+") op-plus) (binop ("-") op-minus) (binop ("*") op-times) (binop ("<") op-less) (binop ("=") op-equal) (binop (">") op-greater) )) (define the-field-names '((a-program defns exp) (proc-definition id bvars body) (lit-exp n) (var-exp id) (binop-exp op e1 e2) (if-exp e1 e2 e3) (call-exp rator rands) )) ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; (sllgen:make-define-datatypes the-lexical-spec the-grammar) (define show-the-datatypes (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) (define scan&parse (sllgen:make-string-parser the-lexical-spec the-grammar)) (define just-scan (sllgen:make-string-scanner the-lexical-spec the-grammar)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; interp.scm ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Continuation-passing interpreter ;;; representing continuations as an ADT ;;; and supporting let and return. (module interp (lib "eopl.ss" "eopl") (require "drscheme-init.scm") (require "lang.scm") (require "data-structures.scm") (require "environments.scm") (provide value-of-program value-of) ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; ;; the-top-level-environment : Env (define the-top-level-environment (init-env)) ;; value-of-program : program -> Answer (define value-of-program (lambda (pgm) (cases program pgm (a-program (defns exp) (set! the-top-level-environment (extend-env-with-defns defns (init-env))) (value-of exp the-top-level-environment (top-level-cont) (error-cont)))))) ;; extend-env-with-defns : Listof[definition] * Env -> Env (define extend-env-with-defns (lambda (defns env) (cond ((null? defns) env) (else (cases definition (car defns) (proc-definition (id bvars body) (extend-env-with-defns (cdr defns) (extend-env id (proc-val (procedure bvars body)) env)))))))) ;; value-of : Exp * Env * Cont * Cont -> Answer (define value-of (lambda (exp env cont econt) (cases expression exp (lit-exp (num) (apply-cont cont (num-val num))) (var-exp (id) (let ((val (apply-env env id))) (if (expval? val) (apply-cont cont val) (eopl:error 'value-of "Unbound variable")))) (binop-exp (op exp1 exp2) (value-of exp1 env (binop-cont1 op exp2 env cont econt) econt)) (if-exp (exp1 exp2 exp3) (value-of exp1 env (if-cont exp2 exp3 env cont econt) econt)) (call-exp (rator rands) (value-of rator env (call-cont1 rands env cont econt) econt)) (let-exp (ids exps body) (cond ((null? ids) (value-of body env cont econt)) (else (value-of (car exps) env (let-cont ids (cdr exps) body '() env cont econt) econt)))) (return-exp (exp1) (value-of exp1 env econt econt)) ))) ;; values-of : Listof[Exp] * Env * MCont * Cont -> Answer (define values-of (lambda (exps env mcont econt) (cond ((null? exps) (apply-mcont mcont '())) (else (value-of (car exps) env (call-cont2 exps env mcont econt) econt))))) ;; apply-binop : binop * ExpVal * ExpVal * Cont -> Answer (define apply-binop (lambda (op val1 val2 cont) (apply-cont cont (cases binop op (op-plus () (num-val (+ (expval->num val1) (expval->num val2)))) (op-minus () (num-val (- (expval->num val1) (expval->num val2)))) (op-times () (num-val (* (expval->num val1) (expval->num val2)))) (op-less () (bool-val (< (expval->num val1) (expval->num val2)))) (op-equal () (bool-val (= (expval->num val1) (expval->num val2)))) (op-greater () (bool-val (> (expval->num val1) (expval->num val2)))))))) ;; apply-procedure : Proc * ExpVal * Cont * Cont -> Answer (define apply-procedure (lambda (proc1 args cont econt) (cases proc proc1 (procedure (bvars body) (value-of body (extend-env* bvars args the-top-level-environment) cont cont))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Continuations. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-datatype continuation continuation? (top-level-cont) (error-cont) (binop-cont1 (op binop?) (exp2 expression?) (env environment?) (cont continuation?) (econt continuation?)) (binop-cont2 (op binop?) (val1 expval?) (cont continuation?)) (if-cont (exp2 expression?) (exp3 expression?) (env environment?) (cont continuation?) (econt continuation?)) (call-cont1 (rands (list-of expression?)) (env environment?) (cont continuation?) (econt continuation?)) (call-cont2 (rands (list-of expression?)) (env environment?) (mcont mcontinuation?) (econt continuation?)) (let-cont (ids (list-of symbol?)) (exps (list-of expression?)) (body expression?) (vals (list-of expval?)) (env environment?) (cont continuation?) (econt continuation?))) (define-datatype mcontinuation mcontinuation? (call-mcont1 (proc proc?) (cont continuation?) (econt continuation?)) (call-mcont2 (val expval?) (mcont mcontinuation?))) ;; apply-cont : Cont * ExpVal -> Answer (define apply-cont (lambda (cont val) (cases continuation cont (top-level-cont () val) (error-cont () (eopl:error "Return outside procedure body")) (binop-cont1 (op exp2 env cont econt) (value-of exp2 env (binop-cont2 op val cont) econt)) (binop-cont2 (op val1 cont) (apply-binop op val1 val cont)) (if-cont (exp2 exp3 env cont econt) (if (expval->bool val) (value-of exp2 env cont econt) (value-of exp3 env cont econt))) (call-cont1 (rands env cont econt) (let ((proc (expval->proc val))) (values-of rands env (call-mcont1 proc cont econt) econt))) (call-cont2 (rands env mcont econt) (values-of (cdr rands) env (call-mcont2 val mcont) econt)) (let-cont (ids exps body vals env cont econt) (cond ((null? exps) (value-of body (extend-env* ids (reverse (cons val vals)) env) cont econt)) (else (value-of (car exps) env (let-cont ids (cdr exps) body (cons val vals) env cont econt) econt))))))) ;; apply-mcont : MCont * Listof[ExpVal] -> Answer (define apply-mcont (lambda (mcont vals) (cases mcontinuation mcont (call-mcont1 (proc cont econt) (apply-procedure proc vals cont econt)) (call-mcont2 (val mcont) (apply-mcont mcont (cons val vals)))))) (define (environment? x) #t) ) Task 4. ======= It is not possible to write such a procedure. Proof: Suppose f were the specified procedure. Then define halts = proc (n) (f n +(n,1)) would solve the halting problem for SIMPLE. Since the halting problem for SIMPLE is undecidable, there is no such f. Task 5. ======= Here is one possible definition of the specified procedure: define f = proc (p q) if <(p,q) then choose ((executeSimple p), (f +(p,1) q)) else (loop) define loop = proc () (loop)