aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--hw08.scm310
1 files changed, 168 insertions, 142 deletions
diff --git a/hw08.scm b/hw08.scm
index ca90d5d..db673c7 100644
--- a/hw08.scm
+++ b/hw08.scm
@@ -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