;;; ;;; clueval.ss ;;; CS200 ;;; ;;; A CLU-like Scheme evaluator based on typed Mini-Scheme. ;;; (require-library "trace.ss") (load "listprocs.ss") (load "assert.ss") (define the-empty-environment '()) (define (make-new-environment frame env) (cons frame env)) (define (first-frame env) (car env)) (define (enclosing-environment env) (cdr env)) (define (make-empty-frame) (list)) (define (extend-environment names types values env) (make-new-environment (map (lambda (name type value) (list name type value)) names types values) env)) (define (environment-lookup-value name env) (if (null? env) (error "No binding for" name) (if (frame-contains? name (first-frame env)) (frame-lookup-value name (first-frame env)) (environment-lookup-value name (enclosing-environment env))))) (define (typeof-variable name env) (if (null? env) (error "No binding for" name) (if (frame-contains? name (first-frame env)) (frame-lookup-type name (first-frame env)) (typeof-variable name (enclosing-environment env))))) (define (bind-variable name value env) (add-binding-to-frame! name value (first-frame env))) (define (add-binding-to-frame! name value frame) (car frame) ;; ! frame cannot be null or append! doesn't work (append! frame (list (cons name value)))) ; Note why we use append! not append (define (frame-contains? name frame) (insertlg (lambda (var result) (if (eq? (car var) name) #t result)) frame #f)) (define (frame-lookup-value name frame) (if (null? frame) (error "Name not found in frame:" name) (if (eq? (car (car frame)) name) (caddr (car frame)) (frame-lookup-value name (cdr frame))))) (define (frame-lookup-type name frame) (if (null? frame) (error "Name not found in frame:" name) (if (eq? (car (car frame)) name) (cadr (car frame)) (frame-lookup-type name (cdr frame))))) (define (tagged-list? expr tag) (if (pair? expr) (eq? (car expr) tag) #f)) (define (primitive-procedure? expr) (tagged-list? expr 'primitive-procedure)) (define (make-primitive-procedure expr) (list 'primitive-procedure expr)) (define (primitive-procedure-procedure procedure) (cadr procedure)) (define (self-evaluating? expr) (or (number? expr) (string? expr) (primitive-procedure? expr))) (define (variable? expr) (symbol? expr)) (define (lambda? expr) (tagged-list? expr 'lambda)) (define (make-lambda params body) (list 'lambda params body)) (define (lambda-parameters expr) (cadr expr)) (define (lambda-body expr) (cddr expr)) (define (make-procedure parameters body environment) (list 'procedure parameters body environment)) (define (compound-procedure? expr) (tagged-list? expr 'procedure)) (define (procedure-parameters procedure) (cadr procedure)) (define (procedure-body procedure) (caddr procedure)) (define (procedure-environment procedure) (cadddr procedure)) (define (application? expr) (pair? expr)) (define (application-operator expr) (car expr)) (define (application-operands expr) (cdr expr)) ;;; ;;; Core of the evaluator - eval and apply ;;; ;;; We have named them "meval" and "mapply" to avoid any confusion with ;;; the built-in Scheme eval and apply. ;;; (define (apply-primitive procedure operands) ;;; The underlying Scheme apply (apply (primitive-procedure-procedure procedure) operands)) (define (mapply procedure operands) (cond ((primitive-procedure? procedure) (apply-primitive procedure operands)) ((compound-procedure? procedure) (meval-sequence (procedure-body procedure) (extend-environment (map (lambda (param) (car param)) (procedure-parameters procedure)) ;; names (map (lambda (param) (cadr param)) (procedure-parameters procedure)) ;; types operands (procedure-environment procedure)))) (else (error "Unknown applicator: " procedure)))) (define (meval-sequence seq env) (if (= (length seq) 1) (meval (car seq) env) (begin (meval (car seq) env) (meval-sequence (cdr seq) env)))) (define (typeof-sequence seq env) (if (= (length seq) 1) (typeof (car seq) env) (begin (typeof (car seq) env) (typeof-sequence (cdr seq) env)))) (define (definition? expr) (tagged-list? expr 'define)) (define (definition-variable expr) (cadr expr)) (define (definition-type expr) (parse-type (caddr expr))) (define (definition-value expr) (cadddr expr)) (define (define-variable! var type value env) ;;; We always add the new definition at the beginning of the frame. That way, ;;; frame-lookup-name will find the new definition first if it is redefined. (set-car! env (cons (list var type value) (car env))) 'ok) ;;; ;;; Added to support type definitions: ;;; (define (type-definition? expr) (tagged-list? expr 'definetype)) (define (type-definition-name expr) (cadr expr)) (define (type-definition-type expr) (parse-type (caddr expr))) (define (make-typedef-type) (list 'typedef-type)) (define (typedef-type? type) (tagged-list? type 'typedef-type)) (define (define-type! name type env) ;;; We put type definitions in the frame like variable definitions, but use ;;; the typedef type to distinguish them. (set-car! env (cons (list name (make-typedef-type) type) (car env))) 'ok) (define (begin? expr) (tagged-list? expr 'begin)) (define (begin-expr1 expr) (cadr expr)) (define (begin-expr2 expr) (caddr expr)) (define (meval expr env) (cond ((self-evaluating? expr) expr) ((variable? expr) (environment-lookup-value expr env)) ((lambda? expr) (make-procedure (lambda-parameters expr) (lambda-body expr) env)) ((begin? expr) (begin (meval (begin-expr1 expr) env) (meval (begin-expr2 expr) env))) ((up? expr) (meval (up-expr expr) env)) ((down? expr) (meval (down-expr expr) env)) ((definition? expr) (define-variable! (definition-variable expr) (definition-type expr) (meval (definition-value expr) env) env)) ((type-definition? expr) (define-type! (type-definition-name expr) (type-definition-type expr) env)) ((application? expr) (mapply (meval (application-operator expr) env) (map (lambda (subexpr) (meval subexpr env)) (application-operands expr)))) ;;; Extensions to support lists ;;; Rather than use the list primitives, we define cons, car and cdr as special ;;; forms to make type-checking work. (else (error "Unknown expression: " exp)))) ;;; A very simple type system ;;; ;;; Type ::= PrimitiveType | ProcedureType | ProductType ;;; ProcedureType ::= Type -> Type ;;; ProductType ::= Type X Type ;;; PrimitiveType ::= Number | String ;;; ;;; Added: ;;; ;;; Type ::= AbstractType ;;; AbstractType ::= Name ;;; (define (make-abstract-type name) (list 'abstract-type name)) (define (abstract-type? type) (tagged-list? type 'abstract-type)) (define (abstract-type-name type) (assert (abstract-type? type)) (cadr type)) ;;; Same as before: (define (make-primitive-type type) (list 'primitive-type type)) (define (primitive-type? type) (tagged-list? type 'primitive-type)) (define (make-error-type) (list 'error-type)) (define (error-type? type) (tagged-list? type 'error-type)) (define (make-any-type) (list 'any-type)) (define (any-type? type) (tagged-list? type 'any-type)) (define (make-number-type) (make-primitive-type 'number)) (define (number-type? type) (and (primitive-type? type) (eq? (cadr type) 'number))) (define (make-string-type) (make-primitive-type 'string)) (define (string-type? type) (and (primitive-type? type) (eq? (cadr type) 'string))) (define (make-empty-type) (make-primitive-type 'empty)) (define (empty-type? type) (and (primitive-type? type) (eq? (cadr type) 'empty))) (define (display-type type) (cond ((procedure-type? type) (string-append "(" (display-type (procedure-type-params type)) ") -> (" (display-type (procedure-type-result type)) ")")) ((product-type? type) (string-append (display-type (product-type-first type)) " x " (display-type (product-type-second type)))) ((abstract-type? type) (symbol->string (abstract-type-name type))) ((number-type? type) "Number") ((string-type? type) "String") ((empty-type? type) "Void") ((error-type? type) "Error") ((any-type? type) "Any") (else (error "Unknown type: " type)))) (define (make-product-type type1 type2) (list 'product-type type1 type2)) (define (product-type? type) (tagged-list? type 'product-type)) (define (product-type-first type) (assert (product-type? type)) (caddr type)) (define (product-type-second type) (assert (product-type? type)) (cadr type)) (define (make-procedure-type params result) (list 'procedure-type params result)) (define (procedure-type? type) (tagged-list? type 'procedure-type)) (define (procedure-type-result type) (assert (procedure-type? type)) (caddr type)) (define (procedure-type-params type) (assert (procedure-type? type)) (cadr type)) (define (typeof-self-evaluating expr) (cond ((number? expr) (make-number-type)) ((string? expr) (make-string-type)) ((primitive-procedure? expr) (error "Can't tell type of primitive")))) ;;; ;;; Asymmetric matching: can t1 be used where t2 is expected ;;; (define (type-match t1 t2) (cond ((or (error-type? t1) (error-type? t2)) #t) ;; error types match anything ((or (error-type? t1) (error-type? t2)) #t) ;; error types match anything ((any-type? t2) #t) ((number-type? t1) (number-type? t2)) ((string-type? t1) (string-type? t2)) ((procedure-type? t1) (and (procedure-type? t2) (type-match (procedure-type-params t1) (procedure-type-params t2)) (type-match (procedure-type-result t1) (procedure-type-result t2)))) ((product-type? t1) (and (product-type? t2) (type-match (product-type-first t1) (product-type-first t2)) (type-match (product-type-second t1) (product-type-second t2)))) ;; Added to support abstract types: ;; Abstract types match only if the names are the same ((abstract-type? t1) (and (abstract-type? t2) (eq? (abstract-type-name t1) (abstract-type-name t2)))) (else (error "Bad type: " t1)))) (define (parse-type type) (cond ((eq? type 'Number) (make-number-type)) ((eq? type 'String) (make-string-type)) ((eq? type 'Any) (make-any-type)) ((list? type) (if (eq? (car type) '->) (make-procedure-type (parse-type (cadr type)) (parse-type (caddr type))) (if (eq? (car type) 'X) (make-product-type (parse-type (cadr type)) (parse-type (caddr type))) (error "Bad type:" type)))) ;;; Any other symbol is an abstract type (will get error later if its not defined) ((symbol? type) (make-abstract-type type)) (else (error "Bad type form:" type)))) (define (parameter-types plist) (typelist-to-product-type (map (lambda (param) (parse-type (cadr param))) plist))) (define (typelist-to-product-type typelist) (if (null? typelist) (make-empty-type) (if (eq? (length typelist) 1) (car typelist) (make-product-type (car typelist) (typelist-to-product-type (cdr typelist)))))) (define (check-procedure-definition expr env) (let ((type (make-procedure-type (parameter-types (lambda-parameters expr)) (parse-type (lambda-result-type expr)))) (params (lambda-parameters expr)) (body (lambda-body expr))) (let ((restype (typeof-sequence body (extend-environment (map (lambda (param) (car param)) params) ;; names (map (lambda (param) (parse-type (cadr param))) params) ;; types (map (lambda (param) 'unknown) params) ;; values env)))) (if (type-match (procedure-type-result type) restype) type (begin (printf "Type mismatch.~n Procedure ~a evaluates to ~a,~n but declared to evaluate to ~a." expr (display-type restype) (display-type (procedure-type-result type))) (make-error-type)))))) (define (typeof-procedure expr env) (let* ((params (lambda-parameters expr)) (body (lambda-body expr)) (param-types (map (lambda (param) (parse-type (cadr param))) params))) (let ((restype (typeof-sequence body (extend-environment (map (lambda (param) (car param)) params) ;; names param-types (map (lambda (param) 'unknown) params) ;; values env)))) (make-procedure-type (typelist-to-product-type param-types) restype)))) (define (typeof-application expr env) (let ((operator (typeof (application-operator expr) env))) (if (procedure-type? operator) (let ((argument-types (typelist-to-product-type (map (lambda (operand) (typeof operand env)) (application-operands expr))))) (if (type-match argument-types (procedure-type-params operator)) (procedure-type-result operator) (begin (printf "Type mismatch.~n Application ~a parameter types are ~a, should be ~a." expr (display-type argument-types) (display-type (procedure-type-params operator))) (make-error-type)))) (begin (printf "Type mismatch.~n Application of non-procedure ~a type ~a." (application-operator expr) (display-type operator)) (make-error-type))))) (define (typeof-definition expr env) (let ((exptype (typeof (definition-value expr) env))) (if (type-match exptype (definition-type expr)) exptype (begin (printf "Type mismatch.~n Definition ~a declared as ~a, expression is ~a." (definition-variable expr) (display-type (definition-type expr)) (display-type exptype)) (make-error-type))))) (define (typeof-type-definition expr env) (make-abstract-type (type-definition-name expr))) (define (up? expr) (tagged-list? expr 'up)) (define (up-type expr) (cadr expr)) (define (up-expr expr) (caddr expr)) (define (down? expr) (tagged-list? expr 'down)) (define (down-type expr) (cadr expr)) (define (down-expr expr) (caddr expr)) (define (typeof-up expr env) (let ((exptype (typeof (up-expr expr) env)) (reptype (environment-lookup-value (up-type expr) env))) (if (type-match exptype reptype) (make-abstract-type (up-type expr)) (begin (printf "Up type error. The type of the expression ~a does not match the representation type ~a." (display-type exptype) (display-type reptype)) (make-error-type))))) (define (typeof-down expr env) (let ((exptype (typeof (down-expr expr) env)) (reptype (environment-lookup-value (down-type expr) env))) (if (type-match exptype (make-abstract-type (down-type expr))) reptype (begin (printf "Down type error. The type of the expression ~a does not match the abstract type ~a." (display-type exptype) (display-type (make-abstract-type (down-type expr)))) (make-error-type))))) (define (typeof expr env) (cond ((self-evaluating? expr) (typeof-self-evaluating expr)) ((variable? expr) (typeof-variable expr env)) ((lambda? expr) (typeof-procedure expr env)) ((definition? expr) (typeof-definition expr env)) ((begin? expr) (begin (typeof (begin-expr1 expr) env) (typeof (begin-expr2 expr) env))) ((up? expr) (typeof-up expr env)) ((down? expr) (typeof-down expr env)) ;;; Added to support type definitions ((type-definition? expr) (typeof-type-definition expr env)) ((application? expr) (typeof-application expr env)) (else (error "Unknown expression: " exp)))) ;;; Mini-scheme can add and multiply using the underlying Scheme primitives: (define the-global-environment (make-new-environment (list (list '+ (make-procedure-type (make-product-type (make-number-type) (make-number-type)) (make-number-type)) (make-primitive-procedure +)) (list '* (make-procedure-type (make-product-type (make-number-type) (make-number-type)) (make-number-type)) (make-primitive-procedure *)) ) the-empty-environment)) (define (check-type expr) (display-type (typeof expr the-global-environment))) (define (teval expr) (let ((exptype (typeof expr the-global-environment))) (if (error-type? exptype) (make-error-type) (meval expr the-global-environment)))) ;;; Mini-scheme is driven by the following driver loop: (define input-prompt ";;; Mini-Scheme input:") (define output-prompt ";;; Mini-Scheme value:") (define (driver-loop) (prompt-for-input input-prompt) (let ((input (read))) (if (eq? input 'quit) (display "Done.") (let ((exptype (typeof input the-global-environment))) (if (error-type? exptype) (begin (newline) (display ";;; Type error - no value")) (let ((output (meval input the-global-environment))) (announce-output output-prompt) (user-print output))) (driver-loop))))) (define (prompt-for-input string) (newline) (newline) (display string) (newline)) (define (announce-output string) (display string) (newline)) (define (user-print object) (if (compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) ')) (display object)))