;; This is an implementation of useful typed language. The language ;; includes type declarations and type definitions, with a case ;; dispatch form. ;; See lecture16.scm to add polymorphism (including polymorphic type ;; definitions) and inference. ;; A record value created by a constrcutor is reprsented by a Scheme ;; vector of 2 elements. The first element in the vector is a symbol ;; tag matching the constrcutor name. The second element is a list ;; that contains the record's fields in order. ;; ====================================================================== ;; Parser ;; ====================================================================== (define scanner-spec '((white-sp (whitespace) skip) (id (letter (arbno (or letter digit "?"))) make-symbol) (number (digit (arbno digit)) make-number))) ;; Then we write the BNF in a paritcular format: (define grammar '((program ((arbno typedef) "in" expression) a-program) ;; Type Declarations ------------------------------ (typedef (id "=" (separated-list variant "or")) a-typedef) ;; example: numlist = (empty) or (cons num numlist) (variant ("(" id (arbno type-expression) ")") a-variant) ;; Expressions ------------------------------ ;; The usual set of expressions... (expression (number) lit-exp) (expression (id) var-exp) (expression (primitive "(" (separated-list expression ",")")") primapp-exp) (expression ("let" (arbno id "=" expression) "in" expression) let-exp) (expression ("letrec" (arbno type-expression id "(" (separated-list type-expression id ",") ")" "=" expression) "in" expression) letrec-exp) (expression ("proc(" (separated-list type-expression id ",") ")" expression) proc-exp) (expression ("(" expression (arbno expression) ")") app-exp) (expression ("ifzero" expression expression expression) ifzero-exp) ;; ...plus an error-raising form... (expression ("!") error-exp) ;; ...and a case-dispatching form. (expression ("cases" id expression "of" (arbno "[" "(" id (arbno id) ")" expression "]")) cases-exp) ;; example: cases numlist l of [(empty) 0][(cons n rest) n] ;; Primitives ------------------------------ (primitive ("+") add-prim) (primitive ("-") subtract-prim) (primitive ("*") mult-prim) (primitive ("add1") incr-prim) (primitive ("sub1") decr-prim) ;; Type Expressions ------------------------------ (type-expression (id) ; a defined type id-texp) (type-expression ("num") num-texp) (type-expression ("(" (separated-list type-expression "*") "->" type-expression ")") proc-texp))) ;; scan&parse : string -> program ;; Parses one program (provided in a string) (define scan&parse (sllgen:make-string-parser scanner-spec grammar)) ;; The parsing support can even generate the define-datatype ;; expressions for us, so the ones above are not needed: (sllgen:make-define-datatypes scanner-spec grammar) ;; ====================================================================== ;; Type Checking ;; ====================================================================== ;; Creating and Parsing Types ---------------------------------------- ;; Types: (define-datatype type type? (number-type) (proc-type (arg-types (list-of type?)) (result-type type?)) (defined-type (name symbol?))) ;; expand-type : type-expression -> type (define (expand-type texpr) (cases type-expression texpr (id-texp (id) (defined-type id)) (num-texp () (number-type)) (proc-texp (arg-texprs result-texpr) (proc-type (map expand-type arg-texprs) (expand-type result-texpr))))) ;; type-of-expression : program -> type (define (type-of-program prog) (cases program prog (a-program (tds expr) (type-of-expression expr ;; Initial tenv has a procedure type for ;; each defined constructor: (make-constructor-type-env tds) tds)))) ;; type-of-expression : expression tenv list-of-typedefs -> type ;; The list of typedefs is used when we find a `cases' expression. (define (type-of-expression exp tenv tds) (cases expression exp (error-exp () (number-type)) (lit-exp (sym) (number-type)) (var-exp (id) (apply-tenv tenv id)) (let-exp (ids rhss body) (let ((rhs-types (map (lambda (rhs) (type-of-expression rhs tenv tds)) rhss))) (type-of-expression body (extend-tenv ids rhs-types tenv) tds))) (letrec-exp (result-texps ids arg-texpss arg-idss rhss body) (let* ([result-types (map expand-type result-texps)] [arg-types (map (lambda (texps) (map expand-type texps)) arg-texpss)] [fun-types (map proc-type arg-types result-types)] [rhs-tenv (extend-tenv ids fun-types tenv)]) (for-each (lambda (result-type rhs arg-ids arg-types) (check-equal-type! result-type (type-of-expression rhs (extend-tenv arg-ids arg-types rhs-tenv) tds) rhs)) result-types rhss arg-idss arg-types) (type-of-expression body rhs-tenv tds))) (proc-exp (texprs ids body) (let ((arg-types (map expand-type texprs))) (let ((result-type (type-of-expression body (extend-tenv ids arg-types tenv) tds))) (proc-type arg-types result-type)))) (app-exp (rator rands) (let ([rator-type (type-of-expression rator tenv tds)] [rand-types (map (lambda (rand) (type-of-expression rand tenv tds)) rands)]) (cases type rator-type (proc-type (arg-types result-type) (check-equal-type! rator-type (proc-type rand-types result-type) exp) result-type) (else (eopl:error 'application "rator type ~s is not a procedure type in ~s" (type-to-external-form rator-type) exp))))) (primapp-exp (prim rands) (type-of-primitive-application prim (map (lambda (rand) (type-of-expression rand tenv tds)) rands) exp)) (ifzero-exp (test-exp then-exp else-exp) (check-equal-type! (type-of-expression test-exp tenv tds) (number-type) test-exp) (let ([then-type (type-of-expression then-exp tenv tds)] [else-type (type-of-expression else-exp tenv tds)]) (check-equal-type! then-type else-type exp) then-type)) (cases-exp (type-id val-exp constr-ids content-idss rhss) ;; Check that the expression we're dispatching on has the declared type: (check-equal-type! (defined-type type-id) (type-of-expression val-exp tenv tds) val-exp) ;; Compare the use of the type name with its declaration; ;; they should match! (let ([variants (lookup-defined-type type-id tds)]) (if (= (length variants) (length constr-ids)) 'ok (eopl:error 'cases "expected ~a variant lines, found ~a" (length variants) (length constr-ids))) ;; Figure out the types for the bound identifiers that sit next ;; to constructor names: (let ([content-typess (map (lambda (var constr-id) (cases variant var (a-variant (id texps) (if (equal? id constr-id) 'ok (eopl:error 'cases "expected variant ~a for type ~a, found ~a" id type-id constr-id)) (map expand-type texps)))) variants constr-ids)]) ;; Now find the type of each variant clause's result expression. (let ([types (map (lambda (content-ids content-types rhs) (type-of-expression rhs (extend-tenv content-ids content-types tenv) tds)) content-idss content-typess rhss)]) (if (null? types) ;; no variants? always produces 0 (number-type) ;; make sure all types match the first one (begin (for-each (lambda (type) (check-equal-type! type (car types) exp)) (cdr types)) (car types))))))))) ;; Checking Primitives ---------------------------------------- (define (check-arg-count! n arg-types exp) (if (= n (length arg-types)) 'ok (eopl:error 'primitive-application "should have ~a argument(s) for the primitive in ~e" n exp))) (define (type-of-binary exp arg-types) (check-arg-count! 2 arg-types exp) (check-equal-type! (car arg-types) (number-type) exp) (check-equal-type! (cadr arg-types) (number-type) exp) (number-type)) (define (type-of-unary exp arg-types) (check-arg-count! 1 arg-types exp) (check-equal-type! (car arg-types) (number-type) exp) (number-type)) (define type-of-primitive-application (lambda (prim arg-types exp) (cases primitive prim (add-prim () (type-of-binary exp arg-types)) (subtract-prim () (type-of-binary exp arg-types)) (mult-prim () (type-of-binary exp arg-types)) (incr-prim () (type-of-unary exp arg-types)) (decr-prim () (type-of-unary exp arg-types))))) ;; Comparing Types ---------------------------------------- ;; check-equal-type! : type type expression -> ;; The expression argument is merely for error reporting. (define check-equal-type! (lambda (t1 t2 exp) (if (equal? t1 t2) 'ok (raise-type-error t1 t2 exp)))) (define (raise-type-error t1 t2 exp) (eopl:error 'check-equal-type! "Type mismatch: ~s doesn't match ~s in ~s~%" (type-to-external-form t1) (type-to-external-form t2) exp)) ;; Type Environment ---------------------------------------- (define-datatype type-environment type-environment? (empty-tenv-record) (extended-tenv-record (names (list-of symbol?)) (types (list-of type?)) (tenv type-environment?))) (define empty-tenv empty-tenv-record) (define extend-tenv extended-tenv-record) (define apply-tenv (lambda (tenv name-to-find) (cases type-environment tenv (empty-tenv-record () (eopl:error 'apply-tenv "unbound variable: ~e" name-to-find)) (extended-tenv-record (names types tenv) (letrec ([search (lambda (names types) (cond [(null? names) (apply-tenv tenv name-to-find)] [else (cond [(eq? (car names) name-to-find) (car types)] [else (search (cdr names) (cdr types))])]))]) (search names types)))))) ;; Reading Type Definitions ---------------------------------------- ;; make-constructor-type-env : list-of-typedefs -> tenv (define (make-constructor-type-env tds) (cond [(null? tds) (empty-tenv)] [else (cases typedef (car tds) (a-typedef (type-id variants) (extend-tenv ;; Get each constructor name in this type: (map (lambda (var) (cases variant var (a-variant (id texps) id))) variants) ;; Build a proc type corresponding to the constrcutor's ;; argument and result types: (map (lambda (var) (cases variant var (a-variant (id texps) (proc-type (map expand-type texps) (defined-type type-id))))) variants) ;; Continue with the remaining type declarations: (make-constructor-type-env (cdr tds)))))])) ;; lookup-defined-type : symbol list-of-typedefs -> list-of-variants (define (lookup-defined-type id tds) (cond [(null? tds) (eopl:error 'cases "no defined type ~a" id)] [else (cases typedef (car tds) (a-typedef (type-id variants) (cond [(eq? type-id id) variants] [else (lookup-defined-type id (cdr tds))])))])) ;; Printing Types ---------------------------------------- (define type-to-external-form (lambda (ty) (cases type ty (defined-type (id) id) (number-type () 'num) (proc-type (arg-types result-type) (list (arg-types-to-external-form arg-types) '-> (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)))))))) ;; ====================================================================== ;; Evaluator ;; ====================================================================== ;; eval-program : program -> num-proc-tree ;; ;; (eval-program (a-program (lit-exp 0))) = 0 ;; (eval-program (a-program (var-exp 'x))) = error ;; (eval-program (a-program (primapp-exp ;; (add-prim) ;; (list (lit-exp 1) ;; (lit-exp 2)))) = 3 (define (eval-program prog) (cases program prog (a-program (tds exp) (eval-expression exp (make-constructor-env tds))))) ;; We have two kinds of procedure values: ;; closures and constructors (define-datatype proc proc? (closure (param (list-of symbol?)) (body expression?) (env list?)) (constructor (variant-name symbol?))) ;; eval-expression : expression env -> num-proc-tree ;; ;; (eval-expression (lit-exp 0) (empty-env)) = 0 ;; (eval-expression (var-exp 'x) ; (extend-env '(x y) '(1 2) (empty-env))) = 1 ;; ... and more examples, based on programs above ... ;; (define (eval-expression expr env) ;; (eopl:printf "(eval-expression ~a ~a)~n" expr env) (cases expression expr (lit-exp (n) n) (var-exp (sym) (apply-env env sym)) (primapp-exp (prim loe) (apply-prim prim (eval-rands loe env))) (let-exp (los loe body) (eval-expression body (extend-env los (eval-rands loe env) env))) (letrec-exp (result-texps ids arg-texps arg-ids rhss body) (eval-expression body (extend-env-recursively ids arg-ids rhss env))) (proc-exp (texpr params body) (closure params body env)) (app-exp (func args) (let ((arg-vals (map (lambda (arg) (eval-expression arg env)) args)) (func-val (eval-expression func env))) (cases proc func-val ;; Closure application proceeds as usual (closure (params body closure-env) (eval-expression body (extend-env params arg-vals closure-env))) ;; A constructor creates a record, which ;; we represent with a Scheme vector (constructor (name) (vector name arg-vals))))) (error-exp () (eopl:error 'eval "program raised ! error")) (ifzero-exp (test-exp then-exp else-exp) (if (= 0 (eval-expression test-exp env)) (eval-expression then-exp env) (eval-expression else-exp env))) (cases-exp (type-id exp constr-ids content-idss rhss) ;; Evaluate the expression to dispatch on, and ;; extract its record tag (let* ([val (eval-expression exp env)] [tag (vector-ref val 0)] [content (vector-ref val 1)]) ;; Now dispatch to the right clause, based on the ;; tag (letrec ([dispatch (lambda (constr-ids content-idss rhss) (cond [(null? constr-ids) 0] [else (cond [(eq? (car constr-ids) tag) (eval-expression (car rhss) ;; Bind local variables ;; to record field values: (extend-env (car content-idss) content env))] [else (dispatch (cdr constr-ids) (cdr content-idss) (cdr rhss))])]))]) (dispatch constr-ids content-idss rhss)))))) ;; ::= '() ;; ::= (cons ) ;; eval-rands : list-of-expr env -> list-of-num-proc-tree ;; takes a list of expression,andproduces the corresponding ;; list of values after evaluating the expressions (define (eval-rands loe env) (cond [(null? loe) '()] [else (cons (eval-expression (car loe)env) (eval-rands (cdr loe) env))])) ;; apply-prim : primitive list-of-nums -> num (define (apply-prim prim lont) ;; (eopl:printf "(apply-prim ~a ~a)~n" prim lon) (cases primitive prim [add-prim () (+ (car lont) (cadr lont))] [subtract-prim () (- (car lont) (cadr lont))] [mult-prim () (* (car lont) (cadr lont))] [incr-prim () (+ (car lont) 1)] [decr-prim () (- (car lont) 1)])) ;; Building Initial Environment ---------------------------------------- ;; make-constructor-env : list-of-typedefs -> env ;; Walk over the type declarations, and find all the variants. (define (make-constructor-env tds) (cond [(null? tds) (empty-env)] [else (cases typedef (car tds) (a-typedef (id variants) (extend-env ;; Get the names of the variants: (map (lambda (var) (cases variant var (a-variant (id texpr) id))) variants) ;; Build a constructor for each variant: (map (lambda (var) (cases variant var (a-variant (id texpr) (constructor id)))) variants) ;; Continue with the remaining declarations: (make-constructor-env (cdr tds)))))])) ;; Environment ---------------------------------------- ;; ::= '() ;; ::= (cons (cons ) ) ;; empty-env : -> env (define (empty-env) '()) ;; extend-env : list-of-symbol list-of-expval env -> env (define (extend-env names vals env) (append (map cons names (map vector vals)) env)) ;; extend-env-recuursively : symbol symbol expression env -> env (define (extend-env-recursively names idss bodys env) (let* ([new-cells (map vector names)] [env (append (map cons names new-cells) env)]) (map (lambda (ids body cell) (vector-set! cell 0 (closure ids body env))) idss bodys new-cells) env)) ;; apply-env : env symbol -> num (define (apply-env env s) (cond [(null? env) (eopl:error 'apply-env "no binding for variable: ~a" s)] [else (cond ;; Check whether the first binding is the one we're ;; looking for [(eq? (car (car env)) s) (vector-ref (cdr (car env)) 0)] ;; If not, look in the rest of the environment: [else (apply-env (cdr env) s)])])) ;; ====================================================================== ;; Top-level Helpers ;; ====================================================================== ;; Provides a prompt that reads programs and evals them: (define read-eval-print (sllgen:make-rep-loop "-->" eval-program (sllgen:make-stream-parser scanner-spec grammar))) ; run : string -> val ; ; Takes a string respresting concrete syntax and ; executes it. ; ; (run "5") = 5 ; (run "proc(num x)x") = closure... ; (define run (lambda (string) (eval-program (scan&parse string)))) ; type-check : string -> val ; ; Takes a string respresting concrete syntax and ; infers types while checking it. If it checks, a value ; is returned representing the type, otherwise an error ; is reported. ; ; (type-check "5") = num ; (type-check "proc(num x)x") = (num -> num) ; (define type-check (lambda (string) (type-to-external-form (type-of-program (scan&parse string))))) ;; ====================================================================== ;; Example programs ;; ====================================================================== (define sum-example "numlist = (empty) or (cons num numlist) in letrec num sum(numlist l) = cases numlist l of [(empty) 0] [(cons i l) +(i,(sum l))] in (sum (cons 1 (cons 20 (cons 14 (empty)))))") ; (type-check sum-example) ; (run sum-example) ;; ---------------------------------------- ;; >>>>>>> Your task for HW 8 ;; ;; Complete the inter-example program to that it produces 55 ;; (or, more precisely, so that it produces #(resnum (55)), ;; since results are implemented with a `result' datatype.) ;; ;; Mostly, this task consists of completeing the `eval' function ;; implementation, but you may also want to write helper functions. ;; ;; The only constraint on your solution is that the (app ...) ;; expression for `sum10' must be intact in the string. We will ;; test your interpreter by replacing the (app ...) with ;; a different program. Of course, your solution must also ;; type check! (define interp-example "exp = (var num) or (lit num) or (lam num exp) or (app exp exp) or (plus exp exp) or (minus exp exp) or (ifz exp exp exp) result = (resnum num) or (closure num exp env) env = (empty) or (extended num result env) in let sum10 = (app (lam 19 (app (app (var 19) (var 19)) (lit 10))) (lam 18 (lam 17 (ifz (var 17) (lit 0) (plus (var 17) (app (app (var 18) (var 18)) (minus (var 17) (lit 1)))))))) in letrec result lookup(num var, env env) = cases env env of [(empty) (resnum !)] [(extended v r nextenv) ifzero -(v, var) r (lookup var nextenv)] in letrec result domath((num * num -> num) op, result r1, result r2) = cases result r1 of [(resnum n1) cases result r2 of [(resnum n2) (resnum (op n1 n2))] [(closure x y z) (resnum !)]] [(closure x y z) (resnum !)] in letrec result eval(exp x, env e) = cases exp x of [(var v) (lookup v e)] [(lit i) (resnum i)] [(lam var body) (closure var body e)] [(app func arg) let funval = (eval func e) argval = (eval arg e) in cases result funval of [(resnum x) (resnum !)] [(closure var body env) (eval body (extended var argval env))]] [(plus e1 e2) (domath proc(num x, num y) +(x,y) (eval e1 e) (eval e2 e))] [(minus e1 e2) (domath proc(num x, num y) -(x,y) (eval e1 e) (eval e2 e))] [(ifz test zero notzero) cases result (eval test e) of [(resnum n) ifzero n (eval zero e) (eval notzero e)] [(closure x y z) (eval notzero e)]] in (eval sum10 (empty))") (type-check interp-example) (run interp-example) ; currently raises an error