diff options
Diffstat (limited to 'hw08.scm')
| -rw-r--r-- | hw08.scm | 394 |
1 files changed, 394 insertions, 0 deletions
diff --git a/hw08.scm b/hw08.scm new file mode 100644 index 0000000..fe329f2 --- /dev/null +++ b/hw08.scm @@ -0,0 +1,394 @@ +#lang eopl + +; 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 +; - 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 +; +; THINGS DO DO (save as 3.9a) + +; ------------------------------------------------------------ +; scanner specification + +(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) )) + +; ------------------------------------------------------------ +; grammar specification + +(define grammar + '( + ; (3.1) program + (program (statement) a-program) + + ; (3.9) statements + (statement (identifier "=" expression) + assign-statement) + (statement ("print" "(" expression ")") + print-statement) + (statement ("{" (separated-list statement ";") "}") + compound-statement) + (statement ("if" expression statement statement) + if-statement) + (statement ("while" expression "do" statement) + while-statement) + (statement ("var" (separated-list identifier ",") ";" statement) + block-statement) + + ; (3.1) expressions + (expression (number) lit-exp) + (expression (identifier) var-exp) + (expression (primitive "(" (separated-list expression ",") ")") + primapp-exp) + + ; (3.3) conditional evaluation + (expression ("if" expression "then" expression "else" expression) + if-exp) + ; (3.4) local binding + (expression ("let" (arbno identifier "=" expression) "in" expression) + let-exp) + + ; (3.5) procedure definition & application + (expression ("proc" "(" (separated-list identifier ",") ")" expression) + proc-exp) + (expression ("(" expression (arbno expression) ")") + app-exp) + + ; (3.6) recursion + (expression ("letrec" + (arbno identifier "(" (separated-list identifier ",") ")" + "=" expression) + "in" expression) + letrec-exp) + + ; (3.7) variable assignment + (expression ("set" identifier "=" expression) + varassign-exp) + + ; (3.7 HW) sequential expressions + (expression ("begin" expression (arbno ";" expression) "end") + begin-exp) + + ; (3.1) primitives + (primitive ("+") add-prim) + (primitive ("-") subtract-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) + )) + +; ------------------------------------------------------------ +; define datatypes before defining interpreter + +(sllgen:make-define-datatypes scanner-spec grammar) +(define dump-datatypes + (lambda () (sllgen:list-define-datatypes scanner-spec grammar))) + +; ------------------------------------------------------------ +; booleans + +(define truth 1) +(define falsity 0) + +(define true-value? (lambda (x) (not (zero? x)))) + +; ------------------------------------------------------------ +; environments + +(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 + (env environment?) )) + +(define empty-env (lambda () (empty-env-record))) + +(define extend-env + (lambda (syms vals env) (extended-env-record syms (list->vector vals) env))) + +(define extend-env-recursively + (lambda (proc-names idss bodies old-env) + (let ((len (length proc-names))) + (let ((vec (make-vector len))) + (let ((env (extended-env-record proc-names vec old-env))) + (for-each + (lambda (pos ids body) + (vector-set! vec pos (closure ids body env))) + (iota len) + idss + bodies) + env))))) + +(define apply-env-ref + (lambda (env sym) + (cases environment env + (empty-env-record () + (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))))))) + +(define apply-env + (lambda (env sym) (deref (apply-env-ref env sym)))) + +(define env-find-position + (lambda (sym los) (list-find-position sym los))) + +(define list-find-position + (lambda (sym los) (list-index (lambda (sym1) (eqv? sym1 sym)) los))) + +(define list-index + (lambda (pred ls) + (cond + ((null? ls) #f) + ((pred (car ls)) 0) + (else (let ((list-index-r (list-index pred (cdr ls)))) + (if (number? list-index-r) (+ list-index-r 1) #f)))))) + +(define iota + (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 + (lambda (pgm) + (cases program pgm + (a-program (statement) + (execute-statement statement (init-env)) )))) + +; (3.9) statement evaluator +(define execute-statement + (lambda (stmt env) + (cases statement stmt + + (assign-statement (id exp) + (setref! + (apply-env-ref env id) + (eval-expression exp env) )) + + (print-statement (exp) + (write (eval-expression exp env)) (newline) ) + + (compound-statement (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) )) + + ; alternate "named" LET syntax + (while-statement (exp statement) (while-loop exp statement env)) + + (block-statement (ids statement) + (execute-statement statement + (extend-env ids (map (lambda (id) 0) ids) env) )) + ))) + +(define while-loop + (lambda (exp stmt env) + (if (true-value? exp) + (lambda () (execute-statement stmt env) (while-loop exp stmt env)) + (#f)))) + +; expression evaluator +(define eval-expression + (lambda (exp env) + (cases expression exp + (lit-exp (datum) datum) + (var-exp (id) (apply-env env id)) + + (primapp-exp (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) )) + + ; (3.4) local binding + (let-exp (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)) + + ; (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)))) + + ; (3.6) recursion + (letrec-exp (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)) + + ; (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.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))) + +; (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))) + (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)) + ))) + +; ------------------------------------------------------------ +; procedures (3.5) + +(define-datatype procval procval? + (closure + (ids (list-of symbol?)) ; formal parameters + (body expression?) ; procedure body + (env environment?))) ; closure (calling environment) + +(define apply-procval + (lambda (proc args) + (cases procval proc + (closure (ids body env) + (if (= (length ids) (length args)) + (eval-expression body (extend-env ids args env)) + (eopl:error 'apply-procval + "wrong number of arguments to procedure ~s" + ids)))))) + +; ------------------------------------------------------------ +; references - for variable assignment (3.7) + +(define-datatype reference reference? + (a-ref + (position integer?) + (vec vector?) )) + +(define primitive-deref + (lambda (ref) + (cases reference ref + (a-ref (pos vec) + (vector-ref vec pos) )))) + +(define primitive-setref! + (lambda (ref value) + (cases reference ref + (a-ref (pos vec) + (vector-set! vec pos value))))) + +(define deref (lambda (ref) (primitive-deref ref))) +(define setref! (lambda (ref value) (primitive-setref! ref value))) + +; ------------------------------------------------------------ +; interpreter + +; scanner only, and parser only +(define scan + (sllgen:make-string-scanner scanner-spec grammar)) +(define scan&parse + (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 + (lambda (s) (execute-program (scan&parse s))) ) + +(define read-eval-print + (sllgen:make-rep-loop "--> " execute-program + (sllgen:make-stream-parser scanner-spec grammar))) + +; ------------------------------------------------------------ +; tests + +(define test-3.1a "add1(2)") +; ignores extra parameters +(define test-3.1b "add1(2,3)") +(define test-3.1c "+(3,4,5)") +; more tests +(define test-3.1d "+(add1(2),-(6,4))") +(define test-3.1e "*(2,+(3,sub1(4)))") +(define test-3.3a "if -(3,+(1,2)) then 2 else 3") +(define test-3.4a "let x = 5 y = 6 in +(x,y)") + +(define test3.5a "print(let f=proc(y,z) +(y,-(z,5)) in (f 2 28))") +(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.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 |