;; This is an implementation of realistic typed language. The language ;; includes type declarations, type definitions, type inference, ;; let-based polymorphism, and polymorphic type constructors. ;; Compared to hw8.scm, polymorphism (including polymorphic type ;; definitions) and inference are added, and they turn out to be ;; significant additions! ;; 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. #| > (type-check "in 1") num > (type-check "foo = (first num) in 1") num > (type-check "foo = (first num) in (first 1)") foo > (type-check "foo = (first num) in (foo 1)") . apply-tenv: unbound variable: foo > (type-check "foo = (first num) or (second num num) in (first 1)") foo > (type-check "foo = (first num) or (second num num) in (second 1)") . check-equal-type!: Type mismatch: ((num * num) -> foo) doesn't match ((num) -> "tvar8") in #3(struct:app-exp #2(struct:var-exp second) (#2(struct:lit-exp 1))) > (type-check "foo = (first num) or (second num num) in (second 1 2)") foo > (type-check "foo = (first num) or (second num foo) in (second 1 2)") . check-equal-type!: Type mismatch: foo doesn't match num in #3(struct:app-exp #2(struct:var-exp second) (#2(struct:lit-exp 1) #2(struct:lit-exp 2))) > (type-check "foo = (first num) or (second num foo) in (second 1 (first 2))") foo > (run "foo = (first num) or (second num foo) in (first 1)") #2(first (1)) > (run "foo = (first num) or (second num foo) in (second 2 (first 1))") #2(second (2 #2(first (1)))) > (run "foo = (first num) or (second num foo) in cases foo (second 2 (first 1)) of [(first n) n] [(second n f) n]") 2 > (run "foo = (first num) or (second num foo) in cases foo (second 2 (first 1)) of [(first n) n] [(second n f) f]") #2(first (1)) > (type-check "foo = (first num) or (second num foo) in cases foo (second 2 (first 1)) of [(first n) n] [(second n f) f]") . check-equal-type!: Type mismatch: foo doesn't match num in #6(struct:cases-exp #2(struct:plain-cases-id foo) #3(struct:app-exp #2(struct:var-exp second) (#2(struct:lit-exp 2) #3(struct:app-exp #2(struct:var-exp first) (#2(struct:lit-exp 1))))) (first second) ((n) (n f)) (#2(struct:var-exp n) #2(struct:var-exp f))) > (type-check "foo = (first num) or (second num foo) in cases foo (second 2 (first 1)) of [(first n) (first n)] [(second n f) f]") foo > (type-check "foo = (first num) or (second num foo) in cases foo (second 2 (first 1)) of [(first n) !] [(second n f) f]") foo > (run "foo = (first num) or (second num foo) in cases foo (second 2 (first 1)) of [(first n) !] [(second n f) f]") #2(first (1)) > (run "foo = (first num) or (second num foo) in cases foo (first 1) of [(first n) !] [(second n f) f]") . eval: program raised ! error > (run "foo = (first num) or (second num foo) in cases foo (first 1) of [(first n) (first !)] [(second n f) f]") |# ;; ====================================================================== ;; Parser ;; ====================================================================== (define scanner-spec '((white-sp (whitespace) skip) (id (letter (arbno (or letter digit "?"))) make-symbol) (number (digit (arbno digit)) make-number))) (define grammar '((program ((arbno typedef) "in" expression) a-program) ;; Type Declarations ------------------------------ ;; We have two forms of type declarations, a plain one... (typedef (id "=" (separated-list variant "or")) plain-typedef) ;; example: numlist = (empty) or (cons num numlist) ;; ... and a polymorphic one. (typedef ("<" (separated-list "'" id "*") ">" id "=" (separated-list variant "or")) polymorphic-typedef) ;; example: <'a>list = (empty) or (cons 'a <'a>list) ;; Each variant of a type has an id for the constructor ;; followed by a sequence of types of the fields: (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. We use cases-id so that ;; a programmer can write either a simple defined type or ;; an instantiated polymorphic type: (expression ("cases" cases-id expression "of" (arbno "[" "(" id (arbno id) ")" expression "]")) cases-exp) ;; example: cases numlist l of [(empty) 0][(cons n rest) n] ;; example: cases list l of [(empty) 0][(cons n rest) n] (cases-id (id) plain-cases-id) (cases-id ("<" (separated-list type-expression "*") ">" id) polymorphic-cases-id) ;; Primitives ------------------------------ (primitive ("+") add-prim) (primitive ("-") subtract-prim) (primitive ("*") mult-prim) (primitive ("add1") incr-prim) (primitive ("sub1") decr-prim) ;; Type Expressions ------------------------------ (type-expression ("num") num-texp) (type-expression ("(" (separated-list type-expression "*") "->" type-expression ")") proc-texp) ;; An identifier in a type position refers to a defined type (non-polymorphic) (type-expression (id) id-texp) ;; Here's the form for referring to a polyumorphic type, with some ;; instantiatation: (type-expression ("<" (separated-list type-expression ",") ">" id) poly-id-texp) ;; A quote is used in front of a type variable: (type-expression ("'" id) var-texp))) ;; scan&parse : string -> program ;; Parses one program (provided in a string) (define scan&parse (sllgen:make-string-parser scanner-spec grammar)) ;; Generate datatype definitions: (sllgen:make-define-datatypes scanner-spec grammar) ;; ====================================================================== ;; Type Checking ;; ====================================================================== ;; Creating and Parsing Types ---------------------------------------- ;; The Type datatype: (define-datatype type type? (number-type) (proc-type (arg-types (list-of type?)) (result-type type?)) (defined-type (name symbol?) (at-types (list-of type?))) (tvar-type (serial-number number?) (container vector?))) ;; To support polymorphism, we will need to ;; distinguish polymorphic bindings (from let) ;; from non-polymorphic ones: (define-datatype type-binding type-binding? (polymorphic (type type?)) (non-polymorphic (type type?))) ;; For naming type variables: (define serial-number 0) ;; expand-type : type-expression list-of-symbol*type -> type ;; As we expand types, we map syntactic type variables to type ;; records using the mapping `local-vars'. For example, the ;; `local-vars' mapping ensures that ('a -> 'a) generates a proc type ;; with the same type variable as the argument and result, instead if ;; having a different type variable for each position in the ;; procedure type. (define (expand-type texpr local-vars) (cases type-expression texpr (poly-id-texp (at-texps id) (defined-type id (map (lambda (texp) (expand-type texp local-vars)) at-texps))) (id-texp (id) (defined-type id '())) (num-texp () (number-type)) (proc-texp (arg-texprs result-texpr) (proc-type (map (lambda (texp) (expand-type texp local-vars)) arg-texprs) (expand-type result-texpr local-vars))) (var-texp (id) (let ([m (assq id local-vars)]) (if m (cdr m) (eopl:error 'expand-type "no binding for type variable '~a" id)))))) ;; find-type-variables : list-of-type-expressions -> list-of-symbol*type ;; Builds a mapping by inding all the type variables in a type. ;; The mapping may have multiple bindings for a syntactic id, ;; but only one will be found later. (define (find-type-variables texprs) (cond [(null? texprs) '()] [else (append (cases type-expression (car texprs) (id-texp (id) '()) (poly-id-texp (at-texps id) (find-type-variables at-texps)) (num-texp () '()) (proc-texp (arg-texprs result-texpr) (append (find-type-variables arg-texprs) (find-type-variables (list result-texpr)))) (var-texp (id) (list (cons id (make-tvar))))) (find-type-variables (cdr texprs)))])) ;; make-tvar : -> type ;; Generates a new type variable (define (make-tvar) (set! serial-number (+ 1 serial-number)) (tvar-type serial-number (vector #f))) ;; The Type Checker ---------------------------------------- ;; 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 () (make-tvar)) ;; can have any type, since it never returns (lit-exp (sym) (number-type)) (var-exp (id) ;; If `id' has a polymorphic binding, we'll need to ;; create fresh type variables for this use; otherwise ;; just extract the non-polymorphic type. (cases type-binding (apply-tenv tenv id) (polymorphic (t) (fresh-type-variables t (vector '()))) (non-polymorphic (t) t))) (let-exp (ids rhss body) (let ((rhs-types (map (lambda (rhs) (type-of-expression rhs tenv tds)) rhss))) (type-of-expression body ;; Add polymorphic bindings... (extend-tenv ids (map polymorphic rhs-types) tenv) tds))) (letrec-exp (result-texps ids arg-texpss arg-idss rhss body) (let* ([local-typess ;; Find all type variables mentioned in the return and ;; argument types for each binding: (map find-type-variables (map cons result-texps arg-texpss))] ;; We use the local-type mappings while parsing the ;; result and argument types: [result-types (map expand-type result-texps local-typess)] [arg-types (map (lambda (texps local-types) (map (lambda (texp) (expand-type texp local-types)) texps)) arg-texpss local-typess)] [fun-types (map proc-type arg-types result-types)] ;; We must use non-polymorphic bindings while checking the ;; right-hand sides, because the body of a function can ;; constrain the result type. [rhs-tenv (extend-tenv ids (map non-polymorphic fun-types) tenv)]) ;; As we check each RHS, add in the types for ;; the letrec-bound function's arguments: (for-each (lambda (result-type rhs arg-ids arg-types) ;; Make sure that the checked body type matches ;; the declared type: (check-equal-type! result-type (type-of-expression rhs (extend-tenv arg-ids (map non-polymorphic arg-types) rhs-tenv) tds) rhs)) result-types rhss arg-idss arg-types) ;; Now check the body expression, with polymorphic bindings: (type-of-expression body (extend-tenv ids (map polymorphic fun-types) tenv) tds))) (proc-exp (texprs ids body) ;; Like `letrec', we generate local types for the ;; procedure's arguments, so that different uses of 'a, ;; for example, constrain each other. (let* ((local-types (find-type-variables texprs)) (arg-types (map (lambda (texp) (expand-type texp local-types)) texprs))) (let ((result-type (type-of-expression body (extend-tenv ids (map non-polymorphic arg-types) tenv) tds))) (proc-type arg-types result-type)))) (app-exp (rator rands) ;; Function-call checking is standard for inference. (let ([rator-type (type-of-expression rator tenv tds)] [rand-types (map (lambda (rand) (type-of-expression rand tenv tds)) rands)] [result-type (make-tvar)]) (check-equal-type! rator-type (proc-type rand-types result-type) exp) result-type)) (primapp-exp (prim rands) ;; Primitive-application checking is straightforward. (type-of-primitive-application prim (map (lambda (rand) (type-of-expression rand tenv tds)) rands) exp)) (ifzero-exp (test-exp then-exp else-exp) ;; if testing is straightforward. (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 (c-id val-exp constr-ids content-idss rhss) ;; c-id will be split into at-texprs (possible null) ;; and type-id; the real work is in `handle': (let ([handle (lambda (at-texprs type-id) ;; Collect local type bindings for the expressions ;; within <...> (if any), and expand those types (if any): (let* ([local-types (find-type-variables at-texprs)] [at-types (map (lambda (texp) (expand-type texp local-types)) at-texprs)]) ;; Check that the expression we're dispatching on has the declared type: (check-equal-type! (defined-type type-id at-types) (type-of-expression val-exp tenv tds) val-exp) ;; Compare the use of the type name with its declaration; ;; they should match! (let* ([variants+at-type-ids (lookup-defined-type type-id tds)] [variants (car variants+at-type-ids)] [at-type-ids (cdr variants+at-type-ids)]) (if (= (length at-types) (length at-type-ids)) 'ok (eopl:error 'cases "expected ~a type parameteriztions using <>, found ~a" (length at-type-ids) (length at-types))) (if (= (length variants) (length constr-ids)) 'ok (eopl:error 'cases "expected ~a variant lines, found ~a" (length variants))) ;; 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 (lambda (texp) ;; While expanding the type expression in the ;; constructor's declaration, we map type variables ;; to the right ones for this particular dispatch. ;; This matters only for polymorphic type declarations. (expand-type texp (map cons at-type-ids at-types))) 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 the environment with the ;; types for field bindings: (extend-tenv content-ids (map non-polymorphic 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))))))))]) (cases cases-id c-id (plain-cases-id (id) (handle '() id)) (polymorphic-cases-id (at-texprs type-id) (handle at-texprs type-id))))))) ;; 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 (cases type t1 (tvar-type (serial-number container) (cases type t2 (tvar-type (serial-number container) (if (vector-ref container 0) (check-equal-type! t1 (vector-ref container 0) exp) (check-equal-tvar! t1 t2 exp))) (else (check-equal-tvar! t1 t2 exp)))) (defined-type (id1 at-types1) (cases type t2 (tvar-type (serial-number container) (check-equal-tvar! t2 t1 exp)) (defined-type (id2 at-types2) (if (and (eq? id1 id2) (= (length at-types1) (length at-types2))) (for-each (lambda (arg1 arg2) (check-equal-type! arg1 arg2 exp)) at-types1 at-types2) (raise-type-error t1 t2 exp))) (else (raise-type-error t1 t2 exp)))) (proc-type (args1 result1) (cases type t2 (tvar-type (serial-number container) (check-equal-tvar! t2 t1 exp)) (proc-type (args2 result2) (if (= (length args1) (length args2)) 'ok (raise-type-error t1 t2 exp)) (for-each (lambda (arg1 arg2) (check-equal-type! arg1 arg2 exp)) args1 args2) (check-equal-type! result1 result2 exp)) (else (raise-type-error t1 t2 exp)))) (else (cases type t2 (tvar-type (serial-number container) (check-equal-tvar! t2 t1 exp)) (else (raise-type-error t1 t2 exp)))))))) (define (check-equal-tvar! tvar t2 exp) (cases type tvar (tvar-type (serial-number container) (if (vector-ref container 0) (check-equal-type! (vector-ref container 0) t2 exp) (begin (check-no-occurrence! tvar t2 exp) (vector-set! container 0 t2)))) (else (eopl:error 'check-equal-tvar! "can't happen!")))) (define check-no-occurrence! (lambda (tvar ty exp) (letrec ((loop (lambda (ty1) (cases type ty1 (defined-type (id at-types) (map loop at-types)) (proc-type (arg-types result-type) (begin (map loop arg-types) (loop result-type))) (tvar-type (num vec) (cond [(eqv? tvar ty1) (raise-occurrence-check tvar ty exp)] [(vector-ref vec 0) (loop (vector-ref vec 0))] [else 'ok])) (else 'ok))))) (loop ty)))) (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)) (define raise-occurrence-check (lambda (tvnum t2 exp) (eopl:error 'check-equal-type! "Can't unify: ~s occurs in type ~s in expr ~s~%" tvnum (type-to-external-form t2) exp))) ;; Fresh Variables for Polymorphism ---------------------------------------- ;; fresh-type-variables : type vector ->type ;; ;; The mapping argument is a vector that remembers already-freshened ;; variables. (define (fresh-type-variables ty mapping) (cases type ty (defined-type (id at-types) (defined-type id (map (lambda (at-type) (fresh-type-variables at-type mapping)) at-types))) (number-type () ty) (proc-type (arg-types result-type) (proc-type (map (lambda (arg-type) (fresh-type-variables arg-type mapping)) arg-types) (fresh-type-variables result-type mapping))) (tvar-type (num vec) (if (vector-ref vec 0) ;; Already set; don't freshen: (fresh-type-variables (vector-ref vec 0) mapping) (let ([m (assoc ty (vector-ref mapping 0))]) (if m ;; Already mapped to fresh: (cdr m) ;; Unconstrained; create a fresh one: (let ([new (make-tvar)]) (vector-set! mapping 0 (cons (cons ty new) (vector-ref mapping 0))) new))))))) ;; Type Environment ---------------------------------------- (define-datatype type-environment type-environment? (empty-tenv-record) (extended-tenv-record (names (list-of symbol?)) (types (list-of type-binding?)) (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 (let ([handle (lambda (type-var-ids type-id variants) (let ([local-types (map (lambda (id) (cons id (make-tvar))) type-var-ids)]) (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) (polymorphic (proc-type (map (lambda (texp) (expand-type texp local-types)) texps) (defined-type type-id (map cdr local-types))))))) variants) (make-constructor-type-env (cdr tds)))))]) (cases typedef (car tds) (plain-typedef (type-id variants) (handle '() type-id variants)) (polymorphic-typedef (type-var-ids type-id variants) (handle type-var-ids type-id variants))))])) ;; lookup-defined-type : symbol list-of-typedefs -> list-of-variant*(list-of-symbol) (define (lookup-defined-type id tds) (cond [(null? tds) (eopl:error 'cases "no defined type ~a" id)] [else (cond [(eq? id (cases typedef (car tds) (plain-typedef (type-id variants) type-id) (polymorphic-typedef (at-type-ids type-id variants) type-id))) (cases typedef (car tds) (plain-typedef (type-id variants) (cons variants '())) (polymorphic-typedef (at-type-ids type-id variants) (cons variants at-type-ids)))] [else (lookup-defined-type id (cdr tds))])])) ;; Printing Types ---------------------------------------- (define type-to-external-form (lambda (ty) (cases type ty (defined-type (id at-types) (if (null? at-types) id (append '(<) (arg-types-to-external-form at-types) (list '> id)))) (number-type () 'num) (proc-type (arg-types result-type) (list (arg-types-to-external-form arg-types) '-> (type-to-external-form result-type))) (tvar-type (serial-number container) (if (vector-ref container 0) (type-to-external-form (vector-ref container 0)) (string-append "tvar" (number->string serial-number))))))) (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 ;; Create constrcutor "functions" ;; and put them in the environment: (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 (c-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)))))) ;; 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 (let ([handle (lambda (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) (make-constructor-env (cdr tds))))]) ;; We have to parse both plain and polymorphic ;; type declarations: (cases typedef (car tds) (plain-typedef (id variants) (handle id variants)) (polymorphic-typedef (at-type-ids id variants) (handle id variants))))])) ;; 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 simple-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 simple-sum-example) (run simple-sum-example) ;; ------------------------------ (define simple-map-example "numlist = (empty) or (cons num numlist) in letrec numlist map((num -> num) f, numlist l) = cases numlist l of [(empty) (empty)] [(cons i l) (cons (f i) (map f l))] in let l = (cons 1 (cons 20 (cons 14 (empty)))) in (map proc(num x)+(x,1) l)")) ;(type-check simple-map-example) ;(run simple-map-example) ;; ------------------------------ (define simple-map2-example "numlist = (empty) or (cons num numlist) numlistlist = (lempty) or (lcons numlist numlistlist) in letrec numlistlist map((num -> numlist) f, numlist l) = cases numlist l of [(empty) (lempty)] [(cons i l) (lcons (f i) (map f l))] in let l = (cons 1 (cons 20 (cons 14 (empty)))) in (map proc(num x)(cons x (empty)) l)")) ;(type-check simple-map2-example) ;(run simple-map2-example) ;; ------------------------------ (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 sum10") ;(type-check interp-example) ;(run interp-example) ;; ------------------------------ (define sum-example "<'a>list = (empty) or (cons 'a <'a>list) in letrec num sum(list l) = cases list 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) ;; ------------------------------ (define map-example "<'a>list = (empty) or (cons 'a <'a>list) twolists = (together list <list>list) in letrec <'b>list map(('a -> 'b) f, <'a>list l) = cases <'a>list l of [(empty) (empty)] [(cons i l) (cons (f i) (map f l))] in let nlist = (cons 1 (cons 20 (cons 14 (empty)))) in (together (map proc(num x)+(x,1) nlist) (map proc(num x)(cons x (empty)) nlist))") ;(type-check map-example) ;(run map-example)