diff options
| -rw-r--r-- | HW05b.scm | 52 | ||||
| -rw-r--r-- | hw09.scm | 588 |
2 files changed, 637 insertions, 3 deletions
@@ -1,85 +1,130 @@ #lang eopl +;; scanner spec (define scanner-spec '( (whitespace (whitespace) skip) (number (digit (arbno digit)) make-number) - (operator ((or "+" "-" "*" "/" "(" ")")) make-symbol))) + (operator ((or "+" "-" "*" "/" "(" ")")) make-symbol))) +;; grammar (define grammar '( + ;; expression - 2+4*2*(1+2+3) (expression (term (arbno add-op term)) arith-expr) + + ;; term - 1*2*3 (term (factor (arbno mult-op factor)) arith-factor) + + ;; factors - 2, (1+2+3) (factor (number) number-factor) (factor ("(" expression ")") expr-factor) + + ;; addition and subtraction (add-op ("+") plus-op) (add-op ("-") minus-op) + + ;; multiplication and division (mult-op ("*") times-op) (mult-op ("/") divide-op) )) +;; make the datatypes (sllgen:make-define-datatypes scanner-spec grammar) (define dump-datatypes (lambda () (sllgen:list-define-datatypes scanner-spec grammar))) - +;; top level expression evaluator (define execute-expression (lambda (expr) (cases expression expr + ;; use a helper function to keep code out of here (arith-expr (term ops terms) (expr-helper term ops terms)) ))) +;; helper function to evaluate an expression (define expr-helper (lambda (term ops terms) (if (null? ops) + ;; single term (eval-term term) + + ;; else, check if there's just one term (if (equal? (length ops) 1) (eval-add-op (car ops) term (car terms)) + ;; else, handle multiple terms 'a )))) +;; evaluates an add operator (define eval-add-op (lambda (op term1 term2) (cases add-op op + + ;; perform addition (plus-op () (+ (eval-term term1) (eval-term term2))) + + ;; perform subtraction (minus-op () (- (eval-term term1) (eval-term term2))) ))) +;; evaluate a term (define eval-term (lambda (term1) (cases term term1 + + ;; use a helper function to keep this one clean (arith-factor (factor ops factors) (term-helper factor ops factors)) ))) +;; helper function for evaluating terms (define term-helper (lambda (factor ops factors) + + ;; if there is a single factor... (if (null? ops) + ;; ... evaluate and return it (eval-factor factor) + + ;; otherwise, if there are 2 factors... (if (equal? (length ops) 1) + + ;; evaluate and return them. (eval-mult-op (car ops) factor (car factors)) + ;; otherwise, handle multiple factors 'b )))) +;; handles multiplication and division (define eval-mult-op (lambda (op fac1 fac2) (cases mult-op op + + ;; perform multiplication (times-op () (* (eval-factor fac1) (eval-factor fac2))) + + ;; perform division (divide-op () (/ (eval-factor fac1) (eval-factor fac2))) ))) +;; evaluate a factor (define eval-factor (lambda (fac) (cases factor fac + + ;; if it's a number, give the number (number-factor (num) num) + + ;; if it's an expression, evaluate the expression (expr-factor (expr) (execute-expression expr)) ))) - +;; SLLGEN things (define scan (sllgen:make-string-scanner scanner-spec grammar)) (define scan&parse @@ -93,4 +138,5 @@ (define read-eval-print (sllgen:make-rep-loop "> " execute-expression (sllgen:make-stream-parser scanner-spec grammar))) +;; shortcut for quicker testing (define spe scan&parse&eval)
\ No newline at end of file diff --git a/hw09.scm b/hw09.scm new file mode 100644 index 0000000..f21c3c5 --- /dev/null +++ b/hw09.scm @@ -0,0 +1,588 @@ +#lang eopl +; 4.3 INTERPRETER +; - this interpreter supports: +; - (3.x) expressions, bindings, procedures, recursion +; - (4.2) type-checking +; - (4.3) abstraction boundaries + +; ------------------------------------------------------------ +; grammar specification for scanner & parser + +(define scanner-spec + '((whitespace (whitespace) skip) + (comment ("%" (arbno (not #\newline))) skip) + (identifier (letter (arbno (or letter digit "_" "-" "?"))) symbol) + (number (digit (arbno digit)) number) )) + +(define parser-spec + '((program (expression) stmt-prog) + ; (3.1) literal numbers and booleans, identifiers, primitive operations + (expression (number) lit-expr) + (expression ("true") true-expr) + (expression ("false") false-expr) + (expression (identifier) var-expr) + (expression (primitive "(" (separated-list expression ",") ")") + primapp-expr) + ; (3.3) conditionals + (expression ("if" expression "then" expression "else" expression) + if-expr) + ; (3.4) local bindings + (expression ("let" (arbno identifier "=" expression) "in" expression) + let-expr) + ; (3.5) procedure definitions(w/types) & applications + (expression ("proc" "(" (separated-list type-exp identifier ",") ")" expression) + proc-expr) + (expression ("(" expression (arbno expression) ")") + app-expr) + ; (3.6) mutually recursive bindings (w/types) + (expression ("letrec" (arbno type-exp identifier + "(" (separated-list type-exp identifier ",") ")" + "=" expression) "in" expression) + letrec-expr) + ; (4.3) type definitions + (expression ("lettype" identifier "=" type-exp + (arbno type-exp identifier + "(" (separated-list type-exp identifier ",") ")" + "=" expression) + "in" expression) + lettype-expr) + + ; (3.1) primitive operations + (primitive ("+") add-prim) + (primitive ("-") sub-prim) + (primitive ("*") mult-prim) + (primitive ("add1") incr-prim) + (primitive ("sub1") decr-prim) + (primitive ("zero?") zero-prim) + + ; (4.2) types + (type-exp ("int") int-type-exp) + (type-exp ("bool") bool-type-exp) + (type-exp (identifier) tid-type-exp) + (type-exp ("(" (separated-list type-exp "*") "->" type-exp ")") proc-type-exp) + )) + + ; ------------------------------------------------------------ +; define data types before defining interpreter + +(sllgen:make-define-datatypes scanner-spec parser-spec) +(define show-the-datatype + (lambda () (sllgen:list-define-datatypes scanner-spec parser-spec)) ) + +; ------------------------------------------------------------ +; types (4.2-4.3, pg 134, revised pg 147) + +(define-datatype type type? + ; named atomic type + (atomic-type (name symbol?)) + ; procedure type (parameter types and result type) + ( proc-type (arg-types (list-of type?)) (result-type type?)) ) + +; primitive types +(define int-type (atomic-type 'int )) +(define bool-type (atomic-type 'bool)) + +; type-expressions +(define expand-type-expression + (lambda (texp tenv) + (cases type-exp texp + ; (4.2) primitive expression types + ( int-type-exp () int-type) + (bool-type-exp () bool-type) + ; (4.3) type definitions + ( tid-type-exp (id) (find-typedef tenv id)) + ; (4.2) procedure types using + ; (4.3) type environment + (proc-type-exp (arg-texps result-texp) + (proc-type + (expand-type-expressions arg-texps tenv) + (expand-type-expression result-texp tenv) )) ))) + +(define expand-type-expressions + (lambda (texps tenv) + (map (lambda (texp) (expand-type-expression texp tenv)) texps))) + +; check that two types are equal +(define check-equal-type! + (lambda (t1 t2 exp) + (or (equal? t1 t2) + (eopl:error 'type-of-expression + "Types didn't match: ~s != ~s in~%~s" + (type-to-external-form t1) + (type-to-external-form t2) + exp)))) + + ; ------------------------------------------------------------ +; type checker (pg 136-137) + +(define type-of-program + (lambda (prog) + (cases program prog + (stmt-prog (exp) (type-of-expression exp (empty-tenv)))))) + +(define type-of-expression + (lambda (expr tenv) + (cases expression expr + ; (4.2) literals - have fixed type + (lit-expr (number) int-type) + (true-expr () bool-type) + (false-expr () bool-type) + ; (4.2) variables (identifiers) - look up in type environment + (var-expr (id) (apply-tenv tenv id)) + ; (4.2) conditionals + (if-expr (test-expr then-expr else-expr) + (let ((test-type (type-of-expression test-expr tenv)) + (then-type (type-of-expression then-expr tenv)) + (else-type (type-of-expression else-expr tenv)) ) + ;; these tests either succeed or raise an error + ; check that test-expr has bool-type + (check-equal-type! test-type bool-type test-expr) + ; check that then-exp and else-exp have the same type + (check-equal-type! then-type else-type expr) + ; return result type (then-expr and else-expr have same type) + then-type)) + ; (4.2) procedure definitions + (proc-expr (texps ids body) + (type-of-proc-expr texps ids body tenv)) + ; (4.2) primitive applications + (primapp-expr (prim rands) + (type-of-application (type-of-primitive prim) + (types-of-expressions rands tenv) + prim rands expr)) + ; (4.2) procedure applications + (app-expr (rator rands) + (type-of-application (type-of-expression rator tenv) + (types-of-expressions rands tenv) + rator rands expr)) + ; (4.2) local bindings + (let-expr (ids rands body) + (type-of-let-expr ids rands body tenv)) + (letrec-expr (result-texps proc-names texpss idss bodies body) + (type-of-letrec-expr + result-texps proc-names texpss idss bodies body tenv)) + ; (4.3) type definitions + (lettype-expr (type-name texp result-texps proc-names texpss idss bodies body) + (type-of-lettype-expr + type-name texp + result-texps proc-names texpss idss bodies body tenv)) + ))) + +; get list of types for list of expressions (typically operands) +(define types-of-expressions + (lambda (rands tenv) + (map (lambda (expr) (type-of-expression expr tenv)) rands) )) + + (define type-of-primitive + (lambda (prim) + (cases primitive prim + ( add-prim () (proc-type (list int-type int-type) int-type)) + ( sub-prim () (proc-type (list int-type int-type) int-type)) + (mult-prim () (proc-type (list int-type int-type) int-type)) + (incr-prim () (proc-type (list int-type) int-type)) + (decr-prim () (proc-type (list int-type) int-type)) + (zero-prim () (proc-type (list int-type) bool-type)) ))) + +(define type-of-proc-expr + (lambda (texps ids body tenv) + ; get argument types and result type (must be inferred from procedure body) + (let ((arg-types (expand-type-expressions texps tenv))) + (let ((result-type (type-of-expression body (extend-tenv ids arg-types tenv)))) + ; proc type is determined by argument types and result type + (proc-type arg-types result-type) )))) + +(define type-of-application + (lambda (rator-type rand-types rator rands exp) + (cases type rator-type + (proc-type (arg-types result-type) + ; if same # of args and rands, and types line up, then return result-type + (if (= (length arg-types) (length rand-types)) + (begin + (for-each check-equal-type! rand-types arg-types rands) + result-type) + (eopl:error 'type-of-expression + (string-append + "Wrong number of arguments in expression" + "~s:~%expected ~s~%got ~s") + exp + (map type-to-external-form arg-types) + (map type-to-external-form rand-types) ))) + (else (eopl:error 'type-of-expression + "Rator not a proc type:~%~s~%had rator type ~s" + rator (type-to-external-form rator-type) )) ))) + +; (4.2) +(define type-of-let-expr + (lambda (ids rands body tenv) + (let ((tenv-for-body (extend-tenv ids (types-of-expressions rands tenv) tenv))) + (type-of-expression body tenv-for-body)))) + + ; (4.2) +(define type-of-letrec-expr + ; takes set of procedures (result types, names, arg types, arg names, and bodies) + ; body in which new type is used, and parent type environment + (lambda (result-texps proc-names texpss idss bodies letrec-body tenv) + ; determine arg types, result types, and resulting procedure types + (let ((arg-typess ; list of lists of argument types + (map (lambda (texps) (expand-type-expressions texps tenv)) texpss)) + (result-types ; list of result types + (expand-type-expressions result-texps tenv) )) + (let ((the-proc-types ; list of procedure types + (map proc-type arg-typess result-types))) + (let ((tenv-for-body ; type env for all proc-bodies + (extend-tenv proc-names the-proc-types tenv))) + ; check that each procedure body matches declared procedure type + (for-each + (lambda (ids arg-types body result-type) + (check-equal-type! + (type-of-expression body (extend-tenv ids arg-types tenv-for-body)) + result-type + body)) + idss arg-typess bodies result-types) + ; return type of letrec-body + (type-of-expression letrec-body tenv-for-body)))))) + +; (4.3) +(define type-of-lettype-expr + ; takes name of new type, type expression for representation, + ; set of procedures (result types, names, arg types, arg names, and bodies) + ; body in which new type is used, and parent type environment + (lambda (type-name texp + result-texps proc-names arg-texpss idss bodies + lettype-body tenv) + (let ((the-new-type (fresh-type type-name)) + (rhs-texps (map proc-type-exp arg-texpss result-texps))) + (let ( + ; for implementation, defined type is bound to definition (TRANSPARENT) + (tenv-for-implementation + (extend-tenv-with-typedef-exp type-name texp tenv)) + ; for client (body), defined type is bound to atomic type (OPAQUE) + (tenv-for-client + (extend-tenv-with-typedef type-name the-new-type tenv))) + (let ((tenv-for-proc ; type env for all proc-bodies + (extend-tenv-with-type-exps + proc-names rhs-texps tenv-for-implementation)) + (tenv-for-body ; type env for body + (extend-tenv-with-type-exps + proc-names rhs-texps tenv-for-client))) + ; check that each procedure body matches declared procedure type + (for-each + (lambda (ids arg-texps body result-texp) + (check-equal-type! + (type-of-expression + body + (extend-tenv-with-type-exps ids arg-texps tenv-for-proc)) + (expand-type-expression result-texp tenv-for-proc) + body)) + idss arg-texpss bodies result-texps) + ; return type of lettype-body + (type-of-expression lettype-body tenv-for-body)))))) + + ; create fresh type based on parameter name (4.3, pg 149) +; - each time this is called, counter is incremented +(define fresh-type + (let ((counter 0)) + (lambda (s) + (set! counter (+ counter 1)) + (atomic-type (string->symbol + (string-append (symbol->string s) (number->string counter)) ))))) + +; extend type environment (4.3, pg 149) +(define extend-tenv-with-typedef-exp + (lambda (typename texp tenv) + (extend-tenv-with-typedef typename (expand-type-expression texp tenv) tenv))) + +; extend type environment (4.3, pg 149) +(define extend-tenv-with-type-exps + (lambda (ids texps tenv) + (extend-tenv ids (expand-type-expressions texps tenv) tenv))) + +; ------------------------------------------------------------ +; type environments + +(define-datatype type-environment type-environment? + ; (4.2) empty & extended type environments + (empty-tenv-record) + (extended-tenv-record (syms (list-of symbol?)) + (vals (list-of type?)) + (tenv type-environment?)) + ; (4.3, pg 146) environment extended with new type definition + (typedef-record (name symbol?) + (definition type?) + (tenv type-environment?) )) + +(define empty-tenv empty-tenv-record) +(define extend-tenv extended-tenv-record) +(define extend-tenv-with-typedef typedef-record) + +; (4.3) +(define apply-tenv + (lambda (tenv sym) + (cases type-environment tenv + (empty-tenv-record () + (eopl:error 'apply-tenv + "Variable ~s unbound in type environment" sym)) + (extended-tenv-record (syms vals tenv) + (let ((pos (list-find-position sym syms))) + (if (number? pos) + (list-ref vals pos) (apply-tenv tenv sym)))) + (typedef-record (name type tenv) + (apply-tenv tenv sym))))) + +; (4.3) +(define find-typedef + (lambda (tenv0 sym) + (let loop ((tenv tenv0)) + (cases type-environment tenv + (empty-tenv-record () + (eopl:error 'apply-tenv + "Type variable ~s unbound in type environment ~s" + sym tenv0)) + (extended-tenv-record (syms vals tenv) (loop tenv)) + (typedef-record (name type tenv) + (if (eqv? name sym) type (loop tenv))))))) + + ; ------------------------------------------------------------ +; external form of types (pg 135) + +(define type-to-external-form + (lambda (ty) + (cases type ty + (atomic-type (name) name) + ( proc-type (arg-types result-type) + (append (arg-types-to-external-form arg-types) '(->) + (list (type-to-external-form result-type)) ))))) + +(define arg-types-to-external-form + (lambda (types) + (if (null? types) + '() + (if (null? (cdr types)) + (list (type-to-external-form (car types))) + (cons (type-to-external-form (car types)) + (cons '* (arg-types-to-external-form (cdr types)) )))))) + +; ------------------------------------------------------------ +; interpreter + +(define eval-expression + (lambda (expr env) + (cases expression expr + (lit-expr (datum) datum) + (true-expr () 1) + (false-expr () 0) + (var-expr (id) (apply-env env id)) + (primapp-expr (prim rands) + (let ((args (eval-primapp-expr-rands rands env))) + (apply-primitive prim args))) + (if-expr (test-expr then-expr else-expr) + (if (true-value? (eval-expression test-expr env)) + (eval-expression then-expr env) + (eval-expression else-expr env))) + (let-expr (ids rands body) + (let ((args (eval-rands rands env))) + (eval-expression body (extend-env ids args env)))) + (proc-expr (texps ids body) + (closure ids body env)) + (app-expr (rator rands) + (let ((proc (eval-expression rator env)) + (args (eval-rands rands env))) + (if (procval? proc) ; always true in typechecked code + (apply-procval proc args) + (eopl:error 'eval-expr "Attempt to apply non-proc ~s" proc) ))) + (letrec-expr (result-texps proc-names texpss idss bodies letrec-body) + (eval-expression letrec-body + (extend-env-recursively proc-names idss bodies env))) + (lettype-expr (type-name texp + result-texps proc-names texpss + idss bodies lettype-body) + (eval-expression lettype-body + (extend-env-recursively proc-names idss bodies env))) + + ))) + + (define eval-program + (lambda (prog) + (cases program prog + (stmt-prog (body) (eval-expression body (empty-env))) ))) + +(define eval-primapp-expr-rands + (lambda (rands env) + (map (lambda (x) (eval-expression x env)) rands))) + +(define eval-rands + (lambda (rands env) + (map (lambda (x) (eval-rand x env)) rands))) + +(define eval-rand + (lambda (rand env) + (eval-expression rand env))) + +(define apply-primitive + (lambda (prim args) + (cases primitive prim + ( add-prim () (+ (car args) (cadr args))) + ( sub-prim () (- (car args) (cadr args))) + (mult-prim () (* (car args) (cadr args))) + (incr-prim () (+ (car args) 1)) + (decr-prim () (- (car args) 1)) + (zero-prim () (if (zero? (car args)) 1 0)) + ))) + +; ------------------------------------------------------------ +; booleans + +(define true-value? (lambda (x) (not (zero? x)))) + +; ------------------------------------------------------------ +; procedures + +(define-datatype procval procval? + (closure + (ids (list-of symbol?)) + (body expression?) + (env environment?) )) + +(define apply-procval + (lambda (proc args) + (cases procval proc + (closure (ids body env) + (eval-expression body (extend-env ids args env)))))) + + ; ------------------------------------------------------------ +; environments + +(define-datatype environment environment? + (empty-env-record) + (extended-env-record + (syms (list-of symbol?)) + (vals vector?) + (env environment?))) + +(define apply-env + (lambda (env sym) + (cases environment env + (empty-env-record () + (eopl:error 'apply--env "No binding for ~s" sym)) + (extended-env-record (syms vals old-env) + (let ((pos (rib-find-position sym syms))) + (if (number? pos) + (vector-ref vals pos) + (apply-env old-env sym))))))) + +(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 rib-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 (end) + (let loop ((next 0)) + (if (>= next end) '() (cons next (loop (+ 1 next)))) ))) + + ; ------------------------------------------------------------ +; interpreter + +(define scan (sllgen:make-string-scanner scanner-spec parser-spec)) +(define scan&parse (sllgen:make-string-parser scanner-spec parser-spec)) + + +(define ext-type-of-program + (lambda (program) + (type-to-external-form (type-of-program program)) )) +(define ext-type-and-eval-program + (lambda (program) + (display "type= ") (display (ext-type-of-program program)) (newline) + (display (eval-program program)) (newline) )) + +; string versions +(define internal-type + (lambda (string) ( type-of-program (scan&parse string))) ) +(define external-type + (lambda (string) ( ext-type-of-program (scan&parse string))) ) +(define run + (lambda (string) ( eval-program (scan&parse string))) ) +(define type&run + (lambda (string) (ext-type-and-eval-program (scan&parse string))) ) + +; loop versions +(define stream-parser (sllgen:make-stream-parser scanner-spec parser-spec)) +; prints internal type or external type for each entered expression +(define read-internal-type + (sllgen:make-rep-loop "--> " type-of-program stream-parser)) +(define read-external-type + (sllgen:make-rep-loop "--> " ext-type-of-program stream-parser)) +; eval each entered expression without or with type checking +(define read-eval-print + (sllgen:make-rep-loop "--> " eval-program stream-parser)) +(define read-type-eval-print + (sllgen:make-rep-loop "--> " ext-type-and-eval-program stream-parser)) + + ; ------------------------------------------------------------ +; tests + +(define test-4a "+(3,4)") +(define test-4b "if zero?(-(2,3)) then 1 else *(2,4)") + +; proc that takes int and adds 1 +(define test-4.2a "proc (int x) add1(x)") +(define test-4.2b "(proc (int x) add1(x) 12)") +; recursive proc that takes int and returns factorial +(define test-4.2c "letrec int fact (int x) + = if zero?(x) then 1 else *(x,(fact sub1(x))) + in fact") +(define test-4.2d "letrec int fact (int x) + = if zero?(x) then 1 else *(x,(fact sub1(x))) + in (fact 4)") + +(type&run test-4.2a) +(type&run test-4.2b) +(type&run test-4.2c) +(type&run test-4.2d) + +; type "myint" which represents 0 as 1, etc. +(define test-4.3a "lettype myint = int + myint zero() = 1 + myint succ(myint x) = add1(x) + myint pred(myint x) = sub1(x) + bool iszero?(myint x) = zero?(sub1(x)) + in (iszero?(pred(succ(zero))))") +(type&run test-4.3a) + +; type "ff" for finite functions (map ints to ints) +(define test-4.3b "lettype ff = (int -> int) + ff zero-ff() % create ff that returns 0 (base case) + = proc (int k) 0 + ff extend-ff(int k, int val, ff old-ff) % extend ff with new pair + = proc (int k1) + if zero?(-(k1,k)) then val else (apply-ff old-ff k1) + int apply-ff(ff f, int k) = (f k) % apply ff to value + in let ff1 = (extend-ff 1 11 (extend-ff 2 22 (zero-ff))) + in (apply-ff ff1 2)") +(type&run test-4.3b)
\ No newline at end of file |