diff options
| -rw-r--r-- | hw08.scm | 310 |
1 files changed, 168 insertions, 142 deletions
@@ -1,23 +1,29 @@ #lang eopl -; 3.9 INTERPRETER +;; Ben Burwell +;; Homework 8 +;; Programming Languages +;; Dr. Kussmaul +;; Due: 15 April 2013 + +;3.9 INTERPRETER ; - the interpreter consists of several components -; - SCANNER - converts characters to tokens -; - PARSER - converts tokens to abstract syntax trees -; - ENVIRONMENT - maps identifiers to values -; - EVALUATOR - converts abstract syntax trees to values/results +; - SCANNER - converts characters to tokens +; - PARSER - converts tokens to abstract syntax trees +; - ENVIRONMENT - maps identifiers to values +; - EVALUATOR - converts abstract syntax trees to values/results ; - this interpreter supports: -; - (3.1) basic functionality -; - whitespace & comments (skipped) -; - integers & built-in defined constants -; - 3 binary primitive operations - add, sub, mult -; - 2 unary primitive operations - incr, decr -; - (3.3) conditionals - if-then-else -; - (3.4) local bindings - let -; - (3.5) procedures - proc, app-exp -; - (3.6) recursion - letrec -; - (3.7) variable assignment - set -; - (3.9) statements - assign, print, compound, if, while, block +; - (3.1) basic functionality +; - whitespace & comments (skipped) +; - integers & built-in defined constants +; - 3 binary primitive operations - add, sub, mult +; - 2 unary primitive operations - incr, decr +; - (3.3) conditionals - if-then-else +; - (3.4) local bindings - let +; - (3.5) procedures - proc, app-expr +; - (3.6) recursion - letrec +; - (3.7) variable assignment - set +; - (3.9) statements - assign, print, compound, if, while, block ; ; THINGS DO DO (save as 3.9a) @@ -26,10 +32,10 @@ (define scanner-spec '( - (whitespace (whitespace) skip) - (comment ("%" (arbno (not #\newline))) skip) - (identifier (letter (arbno (or letter digit "?"))) make-symbol) - (number (digit (arbno digit)) make-number) )) + (whitespace (whitespace) skip) + (comment ("%" (arbno (not #\newline))) skip) + (identifier (letter (arbno (or letter digit "?"))) make-symbol) + (number (digit (arbno digit)) make-number) )) ; ------------------------------------------------------------ ; grammar specification @@ -41,63 +47,63 @@ ; (3.9) statements (statement (identifier "=" expression) - assign-statement) + assign-stmt) (statement ("print" "(" expression ")") - print-statement) + print-stmt) (statement ("{" (separated-list statement ";") "}") - compound-statement) + compound-stmt) (statement ("if" expression statement statement) - if-statement) + if-stmt) (statement ("while" expression "do" statement) - while-statement) + while-stmt) (statement ("var" (separated-list identifier ",") ";" statement) - block-statement) + block-stmt) ; (3.1) expressions - (expression (number) lit-exp) - (expression (identifier) var-exp) + (expression (number) lit-expr) + (expression (identifier) var-expr) (expression (primitive "(" (separated-list expression ",") ")") - primapp-exp) + primapp-expr) ; (3.3) conditional evaluation (expression ("if" expression "then" expression "else" expression) - if-exp) + if-expr) ; (3.4) local binding - (expression ("let" (arbno identifier "=" expression) "in" expression) - let-exp) + (expression ("let" (arbno identifier "=" expression) "in" expression) + let-expr) ; (3.5) procedure definition & application (expression ("proc" "(" (separated-list identifier ",") ")" expression) - proc-exp) + proc-expr) (expression ("(" expression (arbno expression) ")") - app-exp) + app-expr) ; (3.6) recursion - (expression ("letrec" - (arbno identifier "(" (separated-list identifier ",") ")" + (expression ("letrec" + (arbno identifier "(" (separated-list identifier ",") ")" "=" expression) "in" expression) - letrec-exp) + letrec-expr) ; (3.7) variable assignment (expression ("set" identifier "=" expression) - varassign-exp) + varassign-expr) ; (3.7 HW) sequential expressions (expression ("begin" expression (arbno ";" expression) "end") - begin-exp) + begin-expr) ; (3.1) primitives - (primitive ("+") add-prim) - (primitive ("-") subtract-prim) - (primitive ("*") mult-prim) + (primitive ("+") add-prim) + (primitive ("-") sub-prim) + (primitive ("*") mult-prim) (primitive ("add1") incr-prim) (primitive ("sub1") decr-prim) ; (3.3) primitives - (primitive ("equal?") equal-prim) - (primitive ("zero?") zero-prim) - (primitive ("greater?") greater-prim) - (primitive ("less?") less-prim) + (primitive ("equal?") equal-prim) + (primitive ("zero?") zero-prim) + (primitive ("greater?") greater-prim) + (primitive ("less?") less-prim) )) ; ------------------------------------------------------------ @@ -110,7 +116,7 @@ ; ------------------------------------------------------------ ; booleans -(define truth 1) +(define truth 1) (define falsity 0) (define true-value? (lambda (x) (not (zero? x)))) @@ -118,14 +124,14 @@ ; ------------------------------------------------------------ ; environments -(define init-env +(define init-env (lambda () (extend-env '(stdout) '(*uninitialized*) (empty-env)) )) (define-datatype environment environment? (empty-env-record) (extended-env-record (syms (list-of symbol?)) - (vec vector?) ; can use this for anything + (vec vector?) ; can use this for anything (env environment?) )) (define empty-env (lambda () (empty-env-record))) @@ -153,12 +159,13 @@ (eopl:error 'apply-env "no association for symbol ~s" sym)) (extended-env-record (syms vals env) (let ((position (env-find-position sym syms))) - (if (number? position) (a-ref position vals) (apply-env-ref env sym))))))) + (if (number? position) + (a-ref position vals) (apply-env-ref env sym) )))))) (define apply-env (lambda (env sym) (deref (apply-env-ref env sym)))) -(define env-find-position +(define env-find-position (lambda (sym los) (list-find-position sym los))) (define list-find-position @@ -172,14 +179,15 @@ (else (let ((list-index-r (list-index pred (cdr ls)))) (if (number? list-index-r) (+ list-index-r 1) #f)))))) +; returns list of integers from 0 to (n-1) (define iota - (lambda ( n ) (do ((n n (- n 1)) (x '() (cons (- n 1) x))) ((zero? n) x)))) + (lambda (n) (do ((n n (- n 1)) (x '() (cons (- n 1) x))) ((zero? n) x)))) ; ------------------------------------------------------------ ; evaluator ; evaluator for root of abstract syntax tree -(define execute-program +(define execute-program (lambda (pgm) (cases program pgm (a-program (statement) @@ -190,128 +198,132 @@ (lambda (stmt env) (cases statement stmt - (assign-statement (id exp) - (setref! - (apply-env-ref env id) - (eval-expression exp env) )) + (assign-stmt (id exp) + (setref! + (apply-env-ref env id) + (eval-expression exp env) )) - (print-statement (exp) - (write (eval-expression exp env)) (newline) ) + (print-stmt (exp) + (write (eval-expression exp env)) (newline) ) - (compound-statement (statements) - (for-each - (lambda (statement) (execute-statement statement env)) - statements) ) + (compound-stmt (statements) + (for-each + (lambda (statement) (execute-statement statement env)) + statements) ) - (if-statement (exp true-statement false-statement) - (if (true-value? (eval-expression exp env)) - (execute-statement true-statement env) - (execute-statement false-statement env) )) + (if-stmt (exp true-stmt false-stmt) + (if (true-value? (eval-expression exp env)) + (execute-statement true-stmt env) + (execute-statement false-stmt env) )) ; alternate "named" LET syntax - (while-statement (exp statement) - (let loop () - (if (true-value? (eval-expression exp env)) - (begin - (execute-statement statement env) - (loop) )))) + (while-stmt (exp statement) + (let loop () + (if (true-value? (eval-expression exp env)) + (begin + (execute-statement statement env) + (loop) ) + '() ))) - (block-statement (ids statement) - (execute-statement statement - (extend-env ids (map (lambda (id) 0) ids) env) )) + (block-stmt (ids statement) + (execute-statement statement + (extend-env ids (map (lambda (id) 0) ids) env) )) ))) ; expression evaluator (define eval-expression (lambda (exp env) (cases expression exp - (lit-exp (datum) datum) - (var-exp (id) (apply-env env id)) + (lit-expr (datum) datum) + (var-expr (id) (apply-env env id)) - (primapp-exp (prim rands) - (let ((args (eval-rands rands env))) - (apply-primitive prim args))) + (primapp-expr (prim rands) + (let ((args (eval-rands rands env))) + (apply-primitive prim args))) ; (3.3) conditional evaluation - (if-exp (test-exp true-exp false-exp) - (if (true-value? (eval-expression test-exp env)) - (eval-expression true-exp env) - (eval-expression false-exp env) )) + (if-expr (test-expr true-expr false-expr) + (if (true-value? (eval-expression test-expr env)) + (eval-expression true-expr env) + (eval-expression false-expr env) )) ; (3.4) local binding - (let-exp (ids rands body) - (let ((args (eval-rands rands env))) - (eval-expression body (extend-env ids args env)))) + (let-expr (ids rands body) + (let ((args (eval-rands rands env))) + (eval-expression body (extend-env ids args env)))) ; (3.5) procedure definition - (proc-exp (ids body) (closure ids body env)) + (proc-expr (ids body) (closure ids body env)) ; (3.5) procedure application - (app-exp (rator rands) - (let ((proc (eval-expression rator env)) - (args (eval-rands rands env)) ) - (if (procval? proc) - (apply-procval proc args) - (eopl:error 'eval-expression - "attempt to apply non-procedure ~s" - proc)))) + (app-expr (rator rands) + (let ((proc (eval-expression rator env)) + (args (eval-rands rands env)) ) + (if (procval? proc) + (apply-procval proc args) + (eopl:error 'eval-expression + "attempt to apply non-procedure ~s" + proc)))) ; (3.6) recursion - (letrec-exp (proc-names idss bodies letrec-body) - (eval-expression letrec-body - (extend-env-recursively proc-names idss bodies env))) + (letrec-expr (proc-names idss bodies letrec-body) + (eval-expression letrec-body + (extend-env-recursively proc-names idss bodies env))) ; (3.7) variable assignment - (varassign-exp (id rhs-exp) - (begin (setref! - (apply-env-ref env id) - (eval-expression rhs-exp env)) - 1)) + (varassign-expr (id rhs-expr) + (begin (setref! + (apply-env-ref env id) + (eval-expression rhs-expr env)) + 1)) - ; (3.7) sequential expressions - (begin-exp (exp1 exps) - (letrec - ((loop (lambda (acc exps) - (if (null? exps) acc - (loop (eval-expression (car exps) env) - (cdr exps)))))) - (loop (eval-expression exp1 env) exps))) + ; (3.7) sequential expressions + (begin-expr (exp1 exps) + (letrec + ((loop (lambda (acc exps) + (if (null? exps) acc + (loop (eval-expression (car exps) env) + (cdr exps)))))) + (loop (eval-expression exp1 env) exps))) ))) ; (3.4) evaluate operands (define eval-rands (lambda (rands env) (map (lambda (x) (eval-rand x env)) rands))) (define eval-rand - (lambda (rand env) (eval-expression rand env))) + (lambda (rand env) (eval-expression rand env))) ; (3.1) apply primitive operations (define apply-primitive (lambda (prim args) - (define (check arity) - (if (not (= arity (length args))) - (eopl:error 'apply-primitive - "wrong number of arguments to primitive ~s" - prim))) + (define check + (lambda (arity) + (if (not (= arity (length args))) + (eopl:error 'apply-primitive + "wrong number of arguments to primitive ~s" + prim) + '() + ))) (cases primitive prim - (add-prim () (check 2) (+ (car args) (cadr args))) - (subtract-prim () (check 2) (- (car args) (cadr args))) - (mult-prim () (check 2) (* (car args) (cadr args))) - (incr-prim () (check 1) (+ (car args) 1)) - (decr-prim () (check 1) (- (car args) 1)) - (equal-prim () (check 2) (if (= (car args) (cadr args)) truth falsity)) - (zero-prim () (check 1) (if (zero? (car args)) truth falsity)) - (greater-prim () (check 2) (if (> (car args) (cadr args)) truth falsity)) - (less-prim () (check 2) (if (< (car args) (cadr args)) truth falsity)) + ( add-prim () (check 2) (+ (car args) (cadr args))) + ( sub-prim () (check 2) (- (car args) (cadr args))) + ( mult-prim () (check 2) (* (car args) (cadr args))) + ( incr-prim () (check 1) (+ (car args) 1)) + ( decr-prim () (check 1) (- (car args) 1)) + ( equal-prim () (check 2) (if (= (car args) (cadr args)) truth falsity)) + ( zero-prim () (check 1) (if (zero? (car args)) truth falsity)) + ( greater-prim () (check 2) (if (> (car args) (cadr args)) truth falsity)) + ( less-prim () (check 2) (if (< (car args) (cadr args)) truth falsity)) ))) ; ------------------------------------------------------------ ; procedures (3.5) (define-datatype procval procval? - (closure + (closure (ids (list-of symbol?)) ; formal parameters - (body expression?) ; procedure body - (env environment?))) ; closure (calling environment) + (body expression?) ; procedure body + (env environment?))) ; closure (calling environment) (define apply-procval (lambda (proc args) @@ -329,7 +341,7 @@ (define-datatype reference reference? (a-ref (position integer?) - (vec vector?) )) + (vec vector?) )) (define primitive-deref (lambda (ref) @@ -343,7 +355,7 @@ (a-ref (pos vec) (vector-set! vec pos value))))) -(define deref (lambda (ref) (primitive-deref ref))) +(define deref (lambda (ref) (primitive-deref ref))) (define setref! (lambda (ref value) (primitive-setref! ref value))) ; ------------------------------------------------------------ @@ -353,12 +365,12 @@ (define scan (sllgen:make-string-scanner scanner-spec grammar)) (define scan&parse - (sllgen:make-string-parser scanner-spec grammar)) + (sllgen:make-string-parser scanner-spec grammar)) (define read-dump (sllgen:make-rep-loop "--> " (lambda (tree) tree) (sllgen:make-stream-parser scanner-spec grammar))) -(define scan&parse&eval +(define scan&parse&eval (lambda (s) (execute-program (scan&parse s))) ) (define read-eval-print @@ -382,12 +394,26 @@ (define test3.5b "print((proc (x) +(x,2) 4))") (define test3.5c "print(let x=5 in let f=proc(y,z) +(y,-(z,x)) x=28 in (f 2 x))") -(define test3.6a "print(letrec fact(x)=if zero?(x) then 1 else *(x,(fact sub1(x))) -in (fact 6))") -(define test3.6b "print(letrec even(x)=if zero?(x) then 1 else (odd sub1(x)) -odd(x)=if zero?(x) then 0 else (even sub1(x)) -in (odd 13))") +(define test3.6a "print(letrec fact(x)=if zero?(x) then 1 else *(x,(fact sub1(x))) + in (fact 6))") +(define test3.6b "print(letrec even(x)=if zero?(x) then 1 else (odd sub1(x)) + odd(x)=if zero?(x) then 0 else (even sub1(x)) + in (odd 13))") (define test3.9a "var x,y; {x=3; y=4; print(+(x,y))}") -(define test3.9b "var x,y,z; {x=3; y=4; z=0; -while x do {z=+(z,y); x=sub1(x)}; print(z)}")
\ No newline at end of file +(define test3.9b "var x,y,z; {x=3; y=4; z=0; + while x do {z=+(z,y); x=sub1(x)}; print(z)}") + +(define all-tests (list test3.5a test3.5b test3.6a test3.6b test3.9a test3.9b)) + +(scan&parse&eval test3.5a) +(scan&parse&eval test3.5b) +(scan&parse&eval test3.5c) +(scan&parse&eval test3.6a) +(scan&parse&eval test3.6b) +;(scan test3.9a) +;(scan test3.9b) +;(scan&parse test3.9a) +;(scan&parse test3.9b) +(scan&parse&eval test3.9a) +(scan&parse&eval test3.9b)
\ No newline at end of file |