University of Virginia, Department of Computer Science
CS200: Computer Science, Spring 2002

Notes: Monday and Wednesday 1-3 April 2002

Schedule
Type Checking

What is a type?






What is the difference between manifest and latent types?




What is the difference between static and dynamic type checking?





What are the advantages and disadvantages of static type checking?








typeeval.ss

Code changes from meval.ss: 
(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 (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)))))

;;; A very simple type system 
;;;
;;; Type ::= PrimitiveType | ProcedureType | ProductType
;;; ProcedureType ::= Type -> Type
;;; ProductType ::= Type X Type
;;; PrimitiveType ::= Number | String | Boolean
;;;

(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-number-type) (make-primitive-type 'number))
(define (number-type? type) 
  (and (primitive-type? type) (eq? (cadr type) 'number)))

(define (make-boolean-type) (make-primitive-type 'boolean))
(define (boolean-type? type) 
  (and (primitive-type? type) (eq? (cadr type) 'boolean)))

(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))))
   ((number-type? type) "Number")
   ((boolean-type? type) "Boolean")
   ((string-type? type) "String")
   ((empty-type? type) "Void")
   ((error-type? type) "Error")
   (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"))))

(define (type-match t1 t2)
  (cond 
   ((or (error-type? t1) (error-type? t2)) #t) ;; error types match anything
   ((number-type? t1) (number-type? t2))
   ((boolean-type? t1) (boolean-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))))
   (else (error "Bad type: " t1))))

(define (parse-type type)
  (cond
   ((eq? type 'Number) (make-number-type))
   ((eq? type 'Boolean) (make-boolean-type))
   ((eq? type 'String) (make-string-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))))
   (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-sequence seq env)
  (if (= (length seq) 1)
      (typeof (car seq) env)
      (begin
	(typeof (car seq) env)
	(typeof-sequence (cdr seq) env))))

(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)))))))

(define (typeof expr env)
  (cond
   ((self-evaluating? expr) (typeof-self-evaluating expr))
   ((variable? expr)        (typeof-variable expr env))
   ((lambda? expr)          (typeof-procedure expr env))
   ((application? expr)     (typeof-application expr env))
   ((definition? expr)      (typeof-definition expr env))
   (else                    (error "Unknown expression: " exp))))
  
(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)))

CS 655 University of Virginia
Department of Computer Science
CS 200: Computer Science
 David Evans
evans@virginia.edu
Using these Materials