;; Interpreter for a typed language with classes.

;; !! A class must be declared before it is used !!
;; !! as a superclass.                           !!
;; This constraint simplifies the implementation,
;; and ensures that inheritance cycles do not occur.

;; An expval is
;;  * a number,
;;  * null,
;;  * a pair of expvals,
;;  * a procval, or
;;  * an object

;; A denval is
;;  * a location (containing an expval)

;;;;;;;;;;;;;;;; top level interface ;;;;;;;;;;;;;;;;

(define type-check
  (lambda (string)
    (type-to-external-form
      (type-of-program
        (scan&parse string)))))

(define run
  (lambda (string)
    (eval-program (scan&parse string))))

;; (11/13 lecture)
(define translate
  (lambda (string)
    (translation-of-program (scan&parse string))))

;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "_" "-" "?")))
      make-symbol)
    (number (digit (arbno digit)) make-number)
    ))
  
(define the-grammar
  '((program ((arbno class-decl) expression) a-program)

    (expression (number) lit-exp)
    (expression ("true") true-exp)	
    (expression ("false") false-exp)	
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)

    (expression
      ("let" (arbno identifier "=" expression) "in" expression)
      let-exp)

    (expression				
      ("proc" "(" (separated-list type-exp identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression
      ("letrec"
        (arbno type-exp identifier
          "(" (separated-list type-exp identifier ",") ")" 
          "=" expression)
        "in" expression)
      letrec-exp)
    (expression ("set" identifier "=" expression) varassign-exp)
    (expression
      ("begin" expression (arbno ";" expression) "end")
      begin-exp)
    (expression
      ("list" "(" expression (arbno "," expression) ")")
      list-exp)
    (expression
      ("cons" "(" expression "," expression ")")
      cons-exp)
    (expression
      ("car" "(" expression ")" )
      car-exp)
    (expression
      ("cdr" "(" expression ")" )
      cdr-exp)
    (expression 
      ("nil" "[" type-exp "]")
      nil-exp)
    (expression
      ("null?" "(" expression ")" )
      null?-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)

    (class-decl
      (abstraction-specifier
       "class" identifier
       "extends" identifier
         
         (arbno "field" type-exp identifier)
         (arbno method-decl)
         )
      a-class-decl)

    (abstraction-specifier
      ()
      concrete-specifier)

    (abstraction-specifier
      ("abstract")
      abstract-specifier)

    (field-decl                         
      ("field" type-exp identifier)
      a-field-decl)

    (method-decl			
      ("method"
        type-exp	
	identifier 
        "("  (separated-list type-exp identifier ",") ")" ; method ids
         expression  )
      a-method-decl)

    (method-decl
      ("abstractmethod" type-exp identifier 
        "("  (separated-list type-exp identifier ",") ")" ; method ids
        )                               ; no body
      an-abstract-method-decl)

    (expression 
      ("new" identifier "(" (separated-list expression ",") ")")
      new-object-exp)
    (expression
      ("send" expression identifier
        "("  (separated-list expression ",") ")")
      method-app-exp)
    (expression
      ("super" identifier
        "("  (separated-list expression ",") ")")
      super-call-exp)

    (expression
     ("cast" expression identifier)
     cast-exp)

    (type-exp ("int") int-type-exp)
    (type-exp ("bool") bool-type-exp)
    (type-exp ("void") void-type-exp)
    (type-exp (identifier) class-type-exp)
    (type-exp
      ("(" (separated-list type-exp "*") "->" type-exp ")")
      proc-type-exp)
    (type-exp
      ("list" type-exp)
      list-type-exp)

    ;; For the translator target:
    (expression
      ("lexvar" number number)
      lexvar-exp)
    (expression
      ("apply-method-indexed" expression number
	  "("  (separated-list expression ",") ")")
      apply-method-indexed-exp)))

(sllgen:make-define-datatypes the-lexical-spec the-grammar)

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

;; Types (after expansion):
(define-datatype type type?
  (atomic-type
    (name symbol?))
  (list-type
    (value-type type?))
  (class-type
    (name symbol?))
  (proc-type
    (arg-types (list-of type?))
    (result-type type?)))

;; For type-checking:
(define-datatype static-class static-class?
  (a-static-class
    (class-name symbol?)  
    (super-name symbol?)
    (specifier abstraction-specifier?)  
    (field-ids (list-of symbol?))       
    (field-types (list-of type?))       
    (methods static-method-environment?))) 

(define-datatype static-method-struct static-method-struct?
  (a-static-method-struct
    (method-name symbol?)
    (specifier abstraction-specifier?)
    (type type?)
    (super-name symbol?)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; The Interpreter ;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (c-decls body)
        (elaborate-class-decls! c-decls)
        (eval-expression body (init-env))))))

;; eval-expression : expression env -> expval
(define eval-expression
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id) (apply-env env id))
      (lexvar-exp (depth pos) (apply-env-lexvar env depth pos))
      (true-exp () 1)
      (false-exp () 0)
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (if-exp (test-exp true-exp false-exp)
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (let-exp (ids rands body)
        (let ((args (eval-rands rands env)))
          (eval-expression body (extend-env ids args env))))
      (proc-exp (type-exps ids body)
        (closure ids body env))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands      rands env)))
          (if (procval? proc)
            (apply-procval proc args)
            (eopl:error 'eval-expression 
              "Attempt to apply non-procedure ~s" proc))))
      (letrec-exp (result-texps proc-names type-expss idss bodies
                    letrec-body)
        (eval-expression letrec-body
          (extend-env-recursively proc-names idss bodies env)))
      (varassign-exp (id rhs-exp)
        (begin
          (setref! 
            (apply-env-ref env id)
            (eval-expression rhs-exp env))
          1))

      (begin-exp (exp1 exps)
        (let loop ((acc (eval-expression exp1 env))
                   (exps exps))
          (if (null? exps) acc
            (loop (eval-expression (car exps) env) (cdr exps)))))


      ;; lists 
      (list-exp (exp exps) 
        (let ((the-car (eval-expression exp env))
              (the-cdr (eval-rands exps env)))
          (cons the-car the-cdr)))
      (cons-exp (car-exp cdr-exp) 
        (cons
          (eval-expression car-exp env)
          (eval-expression cdr-exp env)))
      (car-exp (exp) 
        (car (eval-expression exp env)))
      (cdr-exp (exp) 
        (cdr (eval-expression exp env)))
      (nil-exp (type-exp) '())
      (null?-exp (exp)
        (if (null? (eval-expression exp env))
          1 0))

      ;; =================== Objects ====================

      (new-object-exp (class-name rands)
        (let ((args (eval-rands rands env))
              (obj (new-object class-name)))
          (find-method-and-apply 'initialize class-name obj args)
          obj))

      (method-app-exp (obj-exp method-name rands)
        (let ((args (eval-rands rands env))
              (obj (eval-expression obj-exp env)))
          (find-method-and-apply
            method-name (object->class-name obj) obj args)))

      (super-call-exp (method-name rands)
        (let ((args (eval-rands rands env))
              (obj (apply-env env 'self)))
          (find-method-and-apply method-name
            (apply-env env '%super) obj args)))

      (cast-exp (exp name)
        (let ((obj (eval-expression exp env)))
          (if (is-subclass? (object->class-name obj) name)
            obj
            (eopl:error 'eval-expression
              "Can't cast object to type ~s:~%~s"
              name (object->class-name obj)))))

      ;; =================== Compiled ====================

      (apply-method-indexed-exp (obj-exp pos rands)
        (let ((obj (eval-expression obj-exp env))
              (args (eval-rands rands env)))
          (let ((class-name (object->class-name obj)))
            (apply-method
              (list-ref
                (class->methods (lookup-class class-name))
                pos)
              obj
              args))))

      (else (eopl:error 'eval-expression
              "~%Illegal expression~%~s" exp)))))

;; eval-rands : lstof-expr env -> lstof-expval
(define eval-rands
  (lambda (exps env)
    (map
      (lambda (exp) (eval-expression exp env))
      exps)))

;; apply-primitive : primitive lstof-expval -> expval
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (+ (car args) (cadr args)))
      (subtract-prim () (- (car args) (cadr args)))
      (mult-prim  () (* (car args) (cadr args)))
      (incr-prim  () (+ (car args) 1))
      (decr-prim  () (- (car args) 1))
      (zero-test-prim () (if (zero? (car args)) 1 0))
      )))

;; init-env : -> env
(define init-env (lambda () (empty-env)))

;;;;;;;;;;;;;;;; classes ;;;;;;;;;;;;;;;;

;; Build and manage the run-time tree of class info.

(define-datatype class class?
  (a-class
    (class-name symbol?)  
    (super-name symbol?) 
    (field-length integer?)  
    (field-ids (list-of symbol?))
    (methods method-environment?)))

;; elaborate-class-decls! : lstof-class-decl ->
;;  Builds up class records given class declarations.
(define elaborate-class-decls!
  (lambda (c-decls)
    (initialize-class-env!)
    (for-each elaborate-class-decl! c-decls)))

;; elaborate-class-decl! : class-decl ->
;;  Build one class record, given one class
;;  declaration. Its superclasses have already been
;;  elaborated.
(define elaborate-class-decl!
  (lambda (c-decl)
    (let ((super-name (class-decl->super-name c-decl)))
      ;; Add local fields to superclass fields:
      (let ((field-ids  (append
                          (class-name->field-ids super-name)
                          (class-decl->field-ids c-decl))))
        (add-to-class-env!
	 ;; Create the record:
	 (a-class
	  (class-decl->class-name c-decl)
	  super-name
	  (length field-ids)
	  field-ids
	  ;; Convert method decls to method records:
	  (roll-up-method-decls c-decl super-name field-ids)))))))

;; roll-up-method-decls : class-decl sym lstof-sym
;;  Converts method-decls to methods. The super-name
;;  and field-ids are atteched to locally-declared methods,
;;  then the locally-declaraed methods are merged with
;;  the superclass methods.
(define roll-up-method-decls
  (lambda (c-decl super-name field-ids)
    (let ((super-name (class-decl->super-name c-decl)))
      (merge-methods
       ;; Get superclass methods: 
       (class-name->methods super-name)
       ;; Build method records for locally declared methods
       (map
	(lambda (m-decl)
	  (a-method m-decl super-name field-ids))
	(class-decl->method-decls c-decl))))))

;; merge-methods : lstof-method lstof-method -> lstof-method
;;  Merges methods defined in a class with methods inherited
;;  from the superclass.
(define merge-methods
  (lambda (super-methods methods)
    (cond
      ((null? super-methods)
       ;; No more super methods; return the local ones.
       methods)
      (else
       ;; Look for override of 1st super method:
       (let ((overriding-method
	      (lookup-method
	       (method->method-name (car super-methods))
	       methods)))
	 (if overriding-method
	     ;; Found it: add overriding version, and
	     ;; remove the overriding method from the list
	     ;; of locally defined methods, so it isn't
	     ;; added to the end.
	     (cons overriding-method
		   (merge-methods 
		    (cdr super-methods)
		    (remove-method overriding-method methods)))
	     ;; No overriding method. Keep the superclass
	     ;; method.
	     (cons (car super-methods)
		   (merge-methods 
		    (cdr super-methods)
		    methods))))))))

;; remove-method : sym lstof-method ->  lstof-method
;;  Removes the named method from the method list.
(define remove-method
  (lambda (method methods)
    (remv method methods)))

(define remv
  (lambda (x lst)
    (cond
      ((null? lst) '())
      ((eqv? (car lst) x) (remv x (cdr lst)))
      (else (cons (car lst) (remv x (cdr lst)))))))

;; is-subclass? : sym sym
;;  Return #t if the class name1 is a subclass
;;  (directly or indirectly) of the class name2
(define is-subclass?
  (lambda (name1 name2)
    (if (eqv? name1 name2)
      #t
      (let ((class (lookup-class name1)))
        (let ((super-name (class->super-name class)))
          (if (eqv? super-name 'object)
            #f
            (is-subclass? super-name name2)))))))

;;;;;;;;;;;;;;;; booleans ;;;;;;;;;;;;;;;;

;; true-value? : number -> bool
(define true-value?
  (lambda (x)
    (not (zero? x))))
        
(define the-true-value 1)
(define the-false-value 0)

;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;

(define-datatype procval procval?
  (closure 
    (ids (list-of symbol?)) 
    (body expression?)
    (env environment?)))

;; apply-procval : procval lstof-expval -> expval
;;  Evaluates the body of a procedure given the actual
;;  arguments
(define apply-procval
  (lambda (proc args)
    (cases procval proc
      (closure (ids body env)
        (eval-expression body (extend-env ids args env))))))

;;;;;;;;;;;;;;;; references ;;;;;;;;;;;;;;;;

(define-datatype reference reference?
  (a-ref
    (position integer?)
    (vec vector?)))

;; deref : reference -> expval
;;  Returns the content of a variable reference
(define deref 
  (lambda (ref)
    (cases reference ref
      (a-ref (pos vec)
        (vector-ref vec pos)))))

;; setref! : reference expval -> number
;;  Changes the content of a variable reference
(define setref! 
  (lambda (ref val)
    (cases reference ref
      (a-ref (pos vec)
        (vector-set! vec pos val)))
    1))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vec vector?)
    (env environment?)))

;; empty-env : -> env
;;  Creates an empty environment
(define empty-env
  (lambda ()
    (empty-env-record)))

;; extend-env : lstof-sym lstof-expval env -> env
;;  Creates an extended environment
(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

;; extend-env-recursively : lstof-sym lstof-lstof-sym
;;                          lstof-expresssion env -> env
;;  Creates an extended environment with recursive procedure
;;  bindings
(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)))))

;; extend-env-refs : lstof-symbol vector env -> env
;;  Creates an extended environment with a pre-made
;;  vector for the variable bindings
(define extend-env-refs
  (lambda (syms vec env)
    (extended-env-record syms vec env)))

;; apply-env-ref : env sym -> reference
;;  Extracts a variable's reference from an environment
(define apply-env-ref
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env-ref "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((pos (env-find-position sym syms)))
          (if (number? pos)
              (a-ref pos vals)
              (apply-env-ref env sym)))))))

;; apply-env : env sym -> expval
;;  Extracts a variable's value (the on in the variable's
;;  reference) from an environment
(define apply-env
  (lambda (env sym)
    (deref (apply-env-ref env sym))))

;; apply-env-lexvar : env num num -> expval
;;  Extracts a variabe's value given its lexical
;;  position in the environment
(define apply-env-lexvar
  (lambda (env depth pos)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env-lexvar
          (string-append
            "~%No such lexical address:"
            "depth = ~s position = ~s")
          depth pos))
      (extended-env-record (syms vals env)
        (if (zero? depth)
          (vector-ref vals pos)
          (apply-env-lexvar env (- depth 1) pos))))))

; - - - - Environment helper functions - - - -

(define env-find-position 
  (lambda (sym los)
    (list-find-last-position sym los)))

(define list-find-last-position
  (lambda (sym los)
    (let loop
      ((los los) (curpos 0) (lastpos #f))
      (cond
        ((null? los) lastpos)
        ((eqv? sym (car los))
         (loop (cdr los) (+ curpos 1) curpos))
        (else (loop (cdr los) (+ curpos 1) lastpos))))))

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

;;;;;;;;;;;;;;;; objects ;;;;;;;;;;;;;;;;

(define-datatype object object? 
  (an-object
    (class-name symbol?)
    (fields vector?)))

;; new-object : sym -> object
;;  Given a class name, creates an instance of the class
(define new-object                      
  (lambda (class-name)
    (an-object
      class-name
      (make-vector (class-name->field-length class-name))))) 

;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;

(define-datatype method method?
  (a-method
    (method-decl method-decl?)
    (super-name symbol?)
    (field-ids (list-of symbol?))))

;; find-method-and-apply : sym sym object lstof-expval -> expval
;;  Given a method name, a class name, an object, and a list
;;  of method argument values, evaluates the appropriate method
;;  body given the object and actual arguments
(define find-method-and-apply           
  (lambda (m-name host-name self args)  
    (let ((method (lookup-method m-name 
                    (class-name->methods host-name))))
      (if (method? method)
          (apply-method method self args)
          (eopl:error 'find-method-and-apply
            "No method for name ~s" m-name)))))

;; apply-method : method object lstof-expval -> expval
;;  Given a method, a class name where the method was
;;  declared, an object of the class, and a list of method
;;  arguments, evalautes the method body.
(define apply-method
  (lambda (method self args)
    (let ((ids (method->ids method))
          (body (method->body method))
          (super-name (method->super-name method))
          (field-ids (method->field-ids method))       
          (fields (object->fields self)))
      (eval-expression body
        (extend-env
          (cons '%super (cons 'self ids))
          (cons super-name (cons self args))
          (extend-env-refs field-ids fields (empty-env)))))))

;;;;;;;;;;;;;;;; method environments ;;;;;;;;;;;;;;;;

(define method-environment? (list-of method?)) 

;; lookup-method-decl : sym lstof-method -> method-decl
;;  Find a method in a list, else return #f
(define lookup-method                
  (lambda (m-name methods)           
    (cond
      ((null? methods) #f)
      ((eqv? m-name (method->method-name (car methods)))
       (car methods))
      (else (lookup-method m-name (cdr methods))))))

;;;;;;;;;;;;;;;; class environments ;;;;;;;;;;;;;;;;

(define the-class-env '())

;; initialize-class-env! : ->
;;  Forget old class records.
(define initialize-class-env!
  (lambda ()
    (set! the-class-env '())))

;; add-to-class-env! : class -> 
;;  Remember one class record.
(define add-to-class-env!
  (lambda (class)
    (set! the-class-env (cons class the-class-env))))

;; lookup-class : sym -> class
;;  Find a class record given the class name.
(define lookup-class                 
  (lambda (name)
    (let loop ((env the-class-env))
      (cond
        ((null? env)
         (eopl:error 'lookup-class
           "Unknown class ~s" name))
        ((eqv? (class->class-name (car env)) name) (car env))
        (else (loop (cdr env)))))))

;;;;;;;;;;;;;;;; selectors ;;;;;;;;;;;;;;;;

(define class-decl->abstraction-specifier
  (lambda (the-c-decl)
    (cases class-decl the-c-decl
      (a-class-decl
        (abstraction-specifier class-name super-name field-texps
          field-ids m-decls) 
        abstraction-specifier))))

(define class-decl->class-name
  (lambda (the-c-decl)
    (cases class-decl the-c-decl
      (a-class-decl
        (abstraction-specifier class-name super-name field-texps
          field-ids m-decls) 
        class-name))))

(define class-decl->super-name
  (lambda (the-c-decl)
    (cases class-decl the-c-decl
      (a-class-decl
        (abstraction-specifier class-name super-name field-texps
          field-ids m-decls) 
        super-name))))

(define class-decl->field-texps
  (lambda (the-c-decl)
    (cases class-decl the-c-decl
      (a-class-decl
        (abstraction-specifier class-name super-name field-texps
          field-ids m-decls) 
        field-texps))))

(define class-decl->field-ids
  (lambda (the-c-decl)
    (cases class-decl the-c-decl
      (a-class-decl
        (abstraction-specifier class-name super-name field-texps
          field-ids m-decls) 
        field-ids))))

(define class-decl->method-decls
  (lambda (the-c-decl)
    (cases class-decl the-c-decl
      (a-class-decl
        (abstraction-specifier class-name super-name field-texps
          field-ids m-decls) 
        m-decls))))

(define method-decl->result-texp
  (lambda (md)
    (cases method-decl md
      (a-method-decl
        (result-texp name arg-type-exps ids method-body)
        result-texp) 
      (an-abstract-method-decl
        (result-texp name arg-type-exps ids) result-texp))))

(define method-decl->method-name
  (lambda (md)
    (cases method-decl md
      (a-method-decl (result-texp name arg-type-exps ids method-body)
        name) 
      (an-abstract-method-decl (result-texp name arg-type-exps ids) name))))

(define method-decl->arg-type-exps
  (lambda (md)
    (cases method-decl md
      (a-method-decl (result-texp name arg-type-exps ids method-body)
        arg-type-exps)
      (an-abstract-method-decl (result-texp name arg-type-exps ids)
        arg-type-exps))))

(define method-decl->ids
  (lambda (md)
    (cases method-decl md
      (a-method-decl (result-texp name arg-type-exps ids method-body)
        ids)
      (an-abstract-method-decl (result-texp name arg-type-exps ids)
        ids))))

(define method-decl->body
  (lambda (md)
    (cases method-decl md
      (a-method-decl (result-texp name arg-type-exps ids
                       method-body)
        method-body)
      (an-abstract-method-decl (result-texp name
                                 arg-type-exps ids) 
        (eopl:error 'method-decl->body
          "Can't take body of abstract method")))))

(define method-decls->method-names
  (lambda (mds)
    (map method-decl->method-name mds)))

(define class->class-name
  (lambda (c-struct)
    (cases class c-struct
      (a-class (class-name super-name field-length field-ids methods)
        class-name))))

(define class->super-name
  (lambda (c-struct)
    (cases class c-struct
      (a-class (class-name super-name field-length field-ids methods)
        super-name))))

(define class->field-length
  (lambda (c-struct)
    (cases class c-struct
      (a-class (class-name super-name field-length field-ids methods)
        field-length))))

(define class->field-ids
  (lambda (c-struct)
    (cases class c-struct
      (a-class (class-name super-name field-length field-ids methods)
        field-ids))))

(define class->methods
  (lambda (c-struct)
    (cases class c-struct
      (a-class (class-name super-name field-length field-ids methods)
        methods))))

(define object->class-name
  (lambda (obj)
    (cases object obj
      (an-object (class-name fields)
        class-name))))

(define object->fields
  (lambda (obj)
    (cases object obj
      (an-object (class-decl fields)
        fields))))

(define object->class-decl
  (lambda (obj)
    (lookup-class (object->class-name obj))))

(define object->field-ids
  (lambda (object)
    (class->field-ids
      (object->class-decl object))))

(define class-name->super-name
  (lambda (class-name)
    (class->super-name (lookup-class class-name))))

(define class-name->field-ids
  (lambda (class-name)
    (if (eqv? class-name 'object) '()
      (class->field-ids (lookup-class class-name)))))

(define class-name->methods
  (lambda (class-name)
    (if (eqv? class-name 'object) '()
      (class->methods (lookup-class class-name)))))

(define class-name->field-length
  (lambda (class-name)
    (if (eqv? class-name 'object)
        0
        (class->field-length (lookup-class class-name)))))

(define method->method-decl
  (lambda (meth)
    (cases method meth
      (a-method (meth-decl super-name field-ids) meth-decl))))

(define method->super-name
  (lambda (meth)
    (cases method meth
      (a-method (meth-decl super-name field-ids) super-name))))

(define method->field-ids
  (lambda (meth)
    (cases method meth
      (a-method (method-decl super-name field-ids) field-ids))))

(define method->method-name
  (lambda (method)
    (method-decl->method-name (method->method-decl method))))

(define method->body
  (lambda (method)
    (method-decl->body (method->method-decl method))))

(define method->ids
  (lambda (method)
    (method-decl->ids (method->method-decl method))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; The Type Checker ;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; type-of-program : program -> type
(define type-of-program
  (lambda (pgm)
    (cases program pgm
      (a-program (c-decls exp)
        (statically-elaborate-class-decls! c-decls)
        (type-of-expression exp (empty-tenv))))))

;; type-of-expression : expr tenv -> type
(define type-of-expression
  (lambda (exp tenv)
    (cases expression exp
      (lit-exp (number) int-type)
      (true-exp () bool-type)
      (false-exp () bool-type)
      (var-exp (id) (apply-tenv tenv id))
      (primapp-exp (prim rands)
        (type-of-application
          (type-of-primitive prim)
          (types-of-expressions rands tenv)
          prim rands exp))
      (if-exp (test-exp true-exp false-exp)
        (let
          ((test-type (type-of-expression test-exp tenv))
           (true-type (type-of-expression true-exp tenv))
           (false-type (type-of-expression false-exp tenv)))
          ;; these tests either succeed or raise an error
          (check-equal-type! test-type bool-type test-exp)
          (check-equal-type! true-type false-type exp)
          true-type))
      (let-exp (ids rands body) (type-of-let-exp ids rands body tenv))
      (proc-exp (texps ids body)
        (type-of-proc-exp texps ids body tenv))
      (app-exp (rator rands) 
        (type-of-application
          (type-of-expression rator tenv)
          (types-of-expressions rands tenv)
          rator rands exp))
      (letrec-exp (result-texps proc-names texpss idss bodies
                    letrec-body)
        (type-of-letrec-exp
          result-texps proc-names texpss idss bodies
          letrec-body tenv))
      (varassign-exp (id rhs)
        (check-is-subtype!
          (type-of-expression rhs tenv)
          (apply-tenv tenv id)
          exp)
        void-type)
      (begin-exp (exp1 exps)                ; love that abstract interpretation!
        (let loop ((acc (type-of-expression exp1 tenv))
                   (exps exps))
          (if (null? exps) acc
            (loop (type-of-expression (car exps) tenv) (cdr exps)))))
      (list-exp (exp1 exps) 
        (type-of-list-exp
          (type-of-expression exp1 tenv)
          (types-of-expressions exps tenv)
          exp1 exps))
      (cons-exp (car-exp cdr-exp) 
        (type-of-cons-exp
          (type-of-expression car-exp tenv)
          (type-of-expression cdr-exp tenv)
          exp))
      (car-exp (exp1) 
        (type-of-car-exp
          (type-of-expression exp1 tenv)
          exp))
      (cdr-exp (exp1) 
        (type-of-cdr-exp
          (type-of-expression exp1 tenv)
          exp))
      (nil-exp (texp) 
        (type-of-nil-exp
          (expand-type-expression texp)))
      (null?-exp (exp1) 
        (type-of-null?-exp 
          (type-of-expression exp1 tenv)
          exp))

      ;; object stuff begins here
      (new-object-exp (class-name rands)
        (type-of-new-obj-exp
          class-name 
          (types-of-expressions rands tenv)
          rands
          exp))
      (method-app-exp (obj-exp msg rands)
        (type-of-method-app-exp 
	  #f ;; #f means not from a new expression
          (type-of-expression obj-exp tenv)
          msg
          (types-of-expressions rands tenv)
          rands
          exp))
      (super-call-exp (msg rands) 
        (type-of-super-call-exp 
          (class-type->name (apply-tenv tenv '%super))
          msg
          (types-of-expressions rands tenv)
          rands
          exp))
      (cast-exp (exp1 class-name)
        (type-of-cast-exp
          (type-of-expression exp1 tenv)
          class-name
          exp))

      (else (eopl:error 'type-of-expression
              "~%Illegal expression~%~s"
              exp)))))


;; type-of-proc-exp : lstof-type-exprs lstof-sym
;;                    expr tenv -> type
;;  Computes the type of a `proc' expression,
;;  given the list of argument type expressions, 
;;  list of argument ids, body expression, and 
;;  type environment.
(define type-of-proc-exp
  (lambda (texps ids body tenv)
    (let ((arg-types (expand-type-expressions texps)))
      (let ((result-type
	     (type-of-expression 
	      body
	      (extend-tenv ids arg-types tenv))))
        (proc-type arg-types result-type)))))

;; type-of-application : type lstof-type expr lstof-expr 
;;                       expr -> void
;;  Computes the type of a procedure application, given
;;  a type for the operator and types for the operands.
;;  The expressions are used for error messages.
(define type-of-application
  (lambda (rator-type rand-types rator rands exp)
    (cases type rator-type
      (proc-type (arg-types result-type)
        (if (= (length arg-types) (length rand-types))
          (begin 
            (for-each
              check-is-subtype!
              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))))))

;; type-of-primitive : primitive -> type
;;  Finds the function type of a primitive.
(define type-of-primitive
  (lambda (prim)
    (cases primitive prim
      (add-prim  ()     (proc-type (list int-type int-type) int-type))
      (subtract-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-test-prim () (proc-type (list int-type) bool-type)))))

;; types-of-expressions : lstof-expr -> lstof-type
(define types-of-expressions
  (lambda (rands tenv)
    (map (lambda (exp) (type-of-expression exp tenv)) rands)))

;; type-of-let-exp : lstof-sym lstof-expr expr tenv -> type
;;  Computes the type of a `let' expression, given
;;  the names of the left-hand variables, the right-hand
;;  expressions, the body expression, and a type environment.
(define type-of-let-exp
  (lambda (ids rands body tenv)
    (let ((new-tenv
            (extend-tenv
              ids
              (types-of-expressions rands tenv)
              tenv)))
      (type-of-expression body new-tenv))))

;; type-of-letrec-exp : lstof-type-expr lstof-sym lstof-lstof-type-expr 
;;                      lstof-lstof-sym lstof-expr expr tenv -> type
;;  Computes the type of a `letrec' expression, given
;;    * the type expressions for the procedure results
;;    * the names of the procedures
;;    * the list of type expressions for each procedure's arguments
;;    * the list of names for each procedure's arguments
;;    * the body for each procedure
;;    * the body of the `lterce' expression
;;    * a type environment
(define type-of-letrec-exp
  (lambda (result-texps proc-names texpss idss bodies
            letrec-body tenv) 
    (let ((arg-typess
	   (map
	    (lambda (texps)
	      (expand-type-expressions texps))
	    texpss))
	  (result-types (expand-type-expressions result-texps)))
      (let ((the-proc-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)))
          (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)
          (type-of-expression letrec-body tenv-for-body))))))

;;;;;;;;;;;;;;;; typechecking list expressions ;;;;;;;;;;;;;;;;

;; type-of-list-exp : type lstof-types expr lstof-expr
;;  Computes the type of a `list' expression
(define type-of-list-exp 
  (lambda (car-type other-types exp1 exps)
    (for-each 
      (lambda (other-type exp)
        (check-equal-type! car-type other-type (list exp1 exp)))
      other-types
      exps)
    (list-type car-type)))

;; type-of-list-exp : type type expr
;;  Computes the type of a `cons' expression
(define type-of-cons-exp
  (lambda (car-type cdr-type exp)
    (cases type cdr-type
      (list-type (type1)
        (check-equal-type! car-type type1 exp)
        cdr-type)
      (else (eopl:error 'type-of-cons-exp
              "~%Cdr not a list type in expression ~%~s ~%cdr type: ~s"
              exp 
              (type-to-external-form cdr-type))))))

;; type-of-list-exp : type expr
;;  Computes the type of a `car' expression
(define type-of-car-exp
  (lambda (type1 exp)
    (cases type type1
      (list-type (type2) type2)
      (else (eopl:error 'type-of-car-exp
              "Argument not of list type in expression ~%~s ~%type: ~s"
              exp
              (type-to-external-form type1))))))

;; type-of-list-exp : type expr
;;  Computes the type of a `cdr' expression
(define type-of-cdr-exp
  (lambda (type1 exp)
    (cases type type1
      (list-type (type2) type1)
      (else (eopl:error 'type-of-cdr-exp
              "~%Argument not of list type in expression ~%~s ~%type: ~s"
              exp
              (type-to-external-form type1))))))

;; type-of-nil-exp : type
;;  Computes the type of a `nil' expression
(define type-of-nil-exp
  (lambda (type1)
    (list-type type1)))

;; type-of-list-exp : type expr
;;  Computes the type of a `null?' expression
(define type-of-null?-exp
  (lambda (type1 exp)
    (cases type type1
      (list-type (type2) bool-type)
      (else (eopl:error 'type-of-null?-exp
              "~%Argument not of list type in expression ~%~s ~%type: ~s"
              exp
              (type-to-external-form type1))))))    

;;;;;;;;;;;;;;;; types of new expressions ;;;;;;;;;;;;;;;;

;; type-of-new-obj-exp : sym lstof-type lstof-exp exp -> type
;;  Computes the type of a `new' expression, given the
;;  class names and list of argument types. The expressions
;;  are for error reporting.
(define type-of-new-obj-exp
  (lambda (class-name rand-types rands exp)
    (cases static-class (statically-lookup-class class-name)
      (a-static-class
        (class-name super-name specifier field-ids
          field-types methods)
	;; First, check whether it's abstract
        (cases abstraction-specifier specifier
          (abstract-specifier ()
            (eopl:error 'type-of-new-obj-exp
              "Can't instantiate abstract class ~s"
              class-name))
          (concrete-specifier ()
	    ;; Not abstract, so check the initialization
            (begin
              (type-of-method-app-exp
	       #t ;; #t means from a new expression
	       (class-type class-name) 
	       'initialize
	       rand-types
	       rands
	       exp)
	      ;; Init args ok, type is object type
	      ;;  for this class
              (class-type class-name))))))))

;; type-of-method-app-exp : bool type sym lstof-type
;;                          lstof-exp exp -> type
;;  Analogous to find-method-and-apply, takes an
;;  object type (containing some class name), a
;;  method name, and a list of argument types, and
;;  finds the type of the method call. The first
;;  argument is #t if the application is for the initialize
;;  call of `new', #f otherwise.
(define type-of-method-app-exp
  (lambda (for-new? obj-type msg rand-types rands exp)
    ;; Disallow `send' with `initialize':
    (if (and (eq? msg 'initialize) (not for-new?))
      (eopl:error 'type-of-method-app-exp
          "~%Can't send message initialize ~%~s"
          exp))
    ;; Make sure target is an object
    (cases type obj-type
      (class-type (class-name)
	;; It's an object. Look for the method.
        ;; All the work is in a helper:
        (type-of-method-app-or-super-call
          #f class-name msg rand-types rands exp))
      (else
        ;; Not an object!
        (eopl:error 'type-of-method-app-exp
          "~%Can't send message to non-object ~s in ~%~s"
          obj-type exp)))))

;; type-of-super-call-exp : sym sym lstof-type 
;;                          lstof-expr expr -> type
;;  Computes the type of a `super' call, given the
;;  name of the superclass, the method name, and
;;  the types of the arguments.
(define type-of-super-call-exp
  (lambda (super-name msg rand-types rands exp)
    ;; All the work is in a helper:
    (type-of-method-app-or-super-call
      #t super-name msg rand-types rands exp)))

;; type-of-method-app-or-super-call : bool sym sym
;;                                    lstof-type 
;;                                    lstof-expr expr -> type
;;  Computes the type of a method call, either a
;;  `send' or `super'. The first argument is #t if it
;;  was a `super' call, #f otherwise. The next two arguments
;;  are the class and method name. The fourth argument
;;  is a list of types for the actual arguments.
;;  The last two arguments are expressions for error
;;  reporting.
(define type-of-method-app-or-super-call
  (lambda (super-call? host-name msg rand-types rands exp)
    ;; Find the method in the table of classes:
    (let ((method
	   (statically-lookup-method 
	    msg
	    (static-class->methods
	     (statically-lookup-class host-name)))))
      (if (static-method-struct? method)
	;; Found it. Check argument count and types
        (cases static-method-struct method
          (a-static-method-struct (method-name specifier
                                    method-type super-name)
	    ;; method-type looks like a procedure type,
            ;; so use type-of-application to compute the
            ;; result type.
            (let ((result-type
                    (type-of-application
		     ;; rator arg will never be used:
                      method-type rand-types '() rands exp)))
	      ;; If it's a super call, make sure the
	      ;; method is not abstract.
              (if super-call?
                (cases abstraction-specifier specifier
                  (concrete-specifier () result-type)
                  (abstract-specifier ()
                    (eopl:error 'type-of-method-or-super-call
                      (string-append
                        "~%Super call on abstract method ~s"
                        "in class ~s in~%~s")
                      msg host-name exp)))
		;; Normal `send'; abstract is ok.
                result-type))))
	;; Didn't find it
        (eopl:error 'type-of-method-app-exp
          "~%Class ~s has no method for ~s in ~%~s"
          host-name msg exp)))))        

;; type-of-cast-exp : type sym expr -> type
;;  Computes the type of a `cast' expression,
;;  given the type of the object expression, the
;;  target class name, and an expression for
;;  error reporting.
(define type-of-cast-exp
  (lambda (ty name2 exp)
    ;; Make sure it's an object type.
    (cases type ty
      (class-type (name1)
	;; Make sure the object type an the target
        ;; type are cmparable, so the cast has some
	;; hope of succeeding.
        (if (or
              (statically-is-subclass? name1 name2)
              (statically-is-subclass? name2 name1))
          (class-type name2)
          (eopl:error 'type-of-expression
            "~%~s incomparable with ~s in ~%~s"
            ty name2 exp)))
      (else
        (eopl:error 'type-of-expression
          "~%~s not an object type in ~%~s"
          ty exp)))))

;;;;;;;;;;;;;;;; typechecking class decls ;;;;;;;;;;;;;;;;

;; Build and manage the check-time tree of class info.
;; The "static" prefix clarifies that these utilities are
;; for type-checking, not for evaluation.

;; statically-elaborate-class-decls! : lstof-class-decl ->
;;  Builds up static class records given class declarations.
(define statically-elaborate-class-decls!
  (lambda (c-decls)
    (initialize-static-class-env!)
    ;; Set up class info
    (for-each statically-elaborate-class-decl! c-decls)
    ;; Check method bodies (needs all class info)
    (for-each check-class-method-bodies! c-decls)))

;; statically-elaborate-class-decl! : class-decl ->
;;  Builds one static class record given a class declaration.
(define statically-elaborate-class-decl!
  (lambda (c-decl)
    (cases class-decl c-decl
      (a-class-decl (specifier class-name super-name
                      field-texps field-ids m-decls)
        (let ((field-ids
                (append
                  (if (eqv? super-name 'object) 
                    '()
                    (static-class->field-ids 
                      (statically-lookup-class super-name)))
                  field-ids))
              (field-types
                (append
                  (if (eqv? super-name 'object) 
                    '()
                    (static-class->field-types
                      (statically-lookup-class super-name)))
                  (expand-type-expressions field-texps)))
              (methods
                (statically-roll-up-method-decls
                  m-decls
                  specifier
                  class-name
                  super-name)))
	  ;; first set up the class env-- this is needed before
	  ;;  checking self in the method bodies.
          (add-to-static-class-env!
            (a-static-class
              class-name
              super-name
              specifier
              field-ids
              field-types
              methods))
	  ;; if this is a concrete class, 
	  ;; check to see that abstract methods have been 
	  ;; filled in:
          (check-for-abstract-methods!  
            specifier methods class-name))))))

;; check-class-method-bodies! : class-decl -> 
;;  Check the methods of a class declaration.
;;  [Note: the book puts this in 
;;   statically-elaborate-class-decl!, but it's better
;;   to check all classes first, so that early classes
;;   can refer to later classes in method bodies.]
(define check-class-method-bodies!
  (lambda (c-decl)
    (cases class-decl c-decl
      (a-class-decl (specifier class-name super-name
                      field-texps field-ids m-decls)
        ;; Extract already-computed information:
	(let ((class (statically-lookup-class class-name)))
	  (let ((field-ids (static-class->field-ids class))
		(field-types (static-class->field-types class))
		(super-name (static-class->super-name class)))
	    ;; Check method bodies:
	    (for-each
	     (lambda (m-decl)
	       (typecheck-method-decl! 
		m-decl
		class-name super-name field-ids field-types))
	     m-decls)))))))

;; statically-roll-up-method-decls : lstof-mdecl specifier
;;                                   sym sym -> lstof-static-method
;;  Produces a static-method-env (= list of static-method)
;;  from the given method-decls.
(define statically-roll-up-method-decls
  (lambda (m-decls specifier self-name super-name)
    (statically-merge-methods self-name
      (if (eqv? super-name 'object)
        '()
        (static-class->methods
          (statically-lookup-class super-name)))
      (map
        (lambda (m-decl)
          (method-decl-to-static-method-struct
            m-decl specifier self-name super-name))
        m-decls))))

;; Static version of merge-methods; while merging, it
;;  checks method consistency (for overriding methods).
(define statically-merge-methods
  (lambda (class-name super-methods methods)
    (cond
      ((null? super-methods) methods)
      (else
        (let ((overriding-method
                (statically-lookup-method
                  (static-method->method-name
                    (car super-methods))
                  methods)))
          (if overriding-method
            (if (or
		 ;; initialize must be able to change types
		 (eqv? 'initialize
		       (static-method->method-name
			(car super-methods)))
		 ;; other methods must have same signature
		 (equal? 
		  (static-method->type overriding-method)
		  (static-method->type
		   (car super-methods))))
              (cons overriding-method
                (statically-merge-methods
                  class-name
                  (cdr super-methods)
                  (remove-method overriding-method methods)))
              (eopl:error 'statically-merge-methods
                (string-append
                  "~%Overriding method ~s in class ~s of"
                  "wrong type~% original: ~s~%new:      ~s")
                (static-method->method-name overriding-method)
                class-name
                (static-method->type (car super-methods))
                (static-method->type overriding-method)))
            (cons (car super-methods)
              (statically-merge-methods
                class-name
                (cdr super-methods)
                methods))))))))

;; method-decl-to-static-method-struct : meth-decl specifier
;;                                       sym sym -> static-method
;;  Converts a method declaration to a static method
;;  record.
(define method-decl-to-static-method-struct
  (lambda (m-decl specifier self-name super-name)
    (cases method-decl m-decl
      (a-method-decl (result-texp name id-texps ids body)
        (a-static-method-struct
          name
          (concrete-specifier)
          (proc-type
            (expand-type-expressions id-texps)
            (expand-type-expression result-texp))
          super-name))
      (an-abstract-method-decl (result-texp name id-texps ids)
        (a-static-method-struct
          name
          (abstract-specifier)
          (proc-type
            (expand-type-expressions id-texps)
            (expand-type-expression result-texp))
          super-name)))))

;; check-for-abstract-methods! : specifier lstof-method
;;                               sym -> 
;;  For a non-abstract class, checks that no method
;;  is abstract.
(define check-for-abstract-methods!
  (lambda (specifier methods class-name)
    (cases abstraction-specifier specifier
      (abstract-specifier () #t)
      (concrete-specifier ()
        (for-each
          (lambda (method)
            (cases abstraction-specifier
              (static-method->abstraction-specifier method) 
              (concrete-specifier () #t)
              (abstract-specifier ()
                (eopl:error 'check-for-abstract-methods!
                  "~%Abstract method ~s in concrete class ~s"
                  (static-method->method-name method)
                  class-name))))
          methods)))))

;; typecheck-method-decl! : method-decl sym sym
;;                          lstof-sym lstof-type
;;  Checks a method body, given the method declaration,
;;  class name for `self', name for `super', list of field names,
;;  and list of field types.
(define typecheck-method-decl!
  (lambda (m-decl self-name super-name field-ids field-types)
    (cases method-decl m-decl
      (a-method-decl (result-texp name id-texps ids body)
        (let ((id-types (expand-type-expressions id-texps)))
          (let ((tenv
                  (extend-tenv
                    (cons '%super (cons 'self ids))
                    (cons (class-type super-name)
                      (cons (class-type self-name)
                        id-types))
                    (extend-tenv
                      field-ids field-types (empty-tenv)))))
            (let ((body-type (type-of-expression body tenv)))
              (check-is-subtype!
                body-type
                (expand-type-expression result-texp)
                m-decl)))))
      (an-abstract-method-decl (result-texp name id-texps ids)
        #t))))

;;;;;;;;;;;;;;;; types ;;;;;;;;;;;;;;;;

;; check-equal-type! : type type exp ->
;;  Raises an error if the two types are not
;;  the same. Uses the expression for error
;;  reporting.
(define check-equal-type!
  (lambda (t1 t2 exp)
    (if (equal? t1 t2)
      #t
      (eopl:error 'type-of-expression
        "Types didn't match: ~s != ~s in~%~s"
        (type-to-external-form t1)
        (type-to-external-form t2)
        exp))))

;; check-is-subtype! : type type exp ->
;;  Raises an error if the first type is not
;;  a subtype of the second one.
(define check-is-subtype!
  (lambda (t1 t2 exp)
    (if (is-subtype? t1 t2)
      #t
      (eopl:error 'check-is-subtype!
        "~%~s is not a subtype of ~s in ~%~s"
        (type-to-external-form t1)
        (type-to-external-form t2)
        exp))))

;; is-subtype? : type type -> bool
;;  Returns #t if the first type is a subtype
;;  of the second one, #f otherwise.
(define is-subtype? 
  (lambda (t1 t2)
    (cases type t1
      (class-type (name1)
        (cases type t2
          (class-type (name2)
            (statically-is-subclass? name1 name2))
          (else #f)))
      (else (equal? t1 t2)))))   

;; statically-is-subclass? : sym sym -> bool
;;  Returns #t if the first class name is declared
;;  as a subtype (directly or indirectly) of the
;;  second class name.
(define statically-is-subclass?
  (lambda (name1 name2)
    (or
      (eqv? name1 name2)
      (if (eqv? name1 'object)
        #f
        (let ((super-name
                (static-class->super-name (statically-lookup-class name1))))
          (statically-is-subclass? super-name name2))))))

;; expand-type-expression : type-expr -> type
;;  Converts a type expression (fro the source code)
;;  to a type.
(define expand-type-expression
  (lambda (texp)
    (cases type-exp texp
      (int-type-exp () int-type)
      (bool-type-exp () bool-type)
      (void-type-exp () void-type)
      (list-type-exp (texp)
        (list-type (expand-type-expression texp)))
      (class-type-exp (name) (class-type name))
      (proc-type-exp (arg-texps result-texp)
        (proc-type
          (expand-type-expressions arg-texps)
          (expand-type-expression  result-texp))))))

;; expand-type-expressions : lstof-type-expr -> lstof-type
(define expand-type-expressions
  (lambda (texps)
    (map expand-type-expression texps)))

(define int-type (atomic-type 'int))
(define bool-type (atomic-type 'bool))
(define void-type (atomic-type 'void))

;;;;;;;;;;;;;;;; type environments ;;;;;;;;;;;;;;;;

(define-datatype type-environment type-environment?
  (empty-tenv-record)
  (extended-tenv-record
    (syms (list-of symbol?))
    (vals (list-of type?))
    (tenv type-environment?)))

;; empty-tenv : -> tenv
(define empty-tenv empty-tenv-record)

;; extend-tenv : lstof-sym lstof-type tenv -> tenv
(define extend-tenv extended-tenv-record)

;; apply-tenv : tenv sym -> type
(define apply-tenv 
  (lambda (tenv sym)
    (cases type-environment tenv
      (empty-tenv-record ()
        (eopl:error 'apply-tenv "~%Unbound variable ~s" sym))
      (extended-tenv-record (syms vals env)
        (let ((pos (list-find-last-position sym syms)))
          (if (number? pos)
            (list-ref vals pos)
            (apply-tenv env sym)))))))
    

;;;;;;;;;;;;;;;; external form of types ;;;;;;;;;;;;;;;;

;; type-to-external-form : type -> value
;;  Converts a type to a printable value
(define type-to-external-form
  (lambda (ty)
    (cases type ty
      (atomic-type (name) name)
      (class-type (name) name)
      (list-type (ty) (list 'list (type-to-external-form ty)))
      (proc-type (arg-types result-type)
        (append
          (formal-types-to-external-form arg-types)
          '(->)
          (list (type-to-external-form result-type)))))))

;; type-to-external-form : lstof-type -> value
;;  Converts a list of types for a procedure type's
;;  arguments to a printable list with * separators.
(define formal-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 '*
                (formal-types-to-external-form (cdr types))))))))

;;;;;;;;;;;;;;;; static method environments ;;;;;;;;;;;;;;;;

(define static-method-environment?
  (list-of static-method-struct?))

;; statically-lookup-method : sym lstof-method -> method
;;  Finds a method record by name in a list
(define statically-lookup-method 
  (lambda (m-name methods)       
    (cond
      ((null? methods) #f)
      ((eqv? m-name (static-method->method-name (car methods)))
       (car methods))
      (else (statically-lookup-method m-name (cdr methods))))))

;;;;;;;;;;;;;;;; static class environments ;;;;;;;;;;;;;;;;

(define the-static-class-env '())

;; initialize-static-class-env! : ->
;;  Forgets old static class records
(define initialize-static-class-env!
  (lambda ()
    (set! the-static-class-env '())))

;; add-to-static-class-env! : static-class ->
;;  Rememebers one static class record.
(define add-to-static-class-env!
  (lambda (class)
    (set! the-static-class-env (cons class the-static-class-env))))

;; statically-lookup-class : sym -> static-class
;;  Finds a static class record by name.
(define statically-lookup-class 
  (lambda (name)
    (let loop ((env the-static-class-env))
      (cond
        ((null? env)
         (eopl:error 'statically-lookup-class
           "~%Unknown class ~s" name))
        ((eqv? (static-class->class-name (car env)) name) (car env))
        (else (loop (cdr env)))))))

;;;;;;;;;;;;;;;; selectors ;;;;;;;;;;;;;;;;

(define static-class->class-name
  (lambda (sc)
    (cases static-class sc
      (a-static-class
        (class-name super-name specifier  field-ids
          field-types methods)
        class-name))))

(define static-class->super-name
  (lambda (sc)
    (cases static-class sc
      (a-static-class
        (class-name super-name specifier  field-ids
          field-types methods)
        super-name))))

(define static-class->field-ids
  (lambda (sc)
    (cases static-class sc
      (a-static-class
        (class-name super-name specifier  field-ids
          field-types methods)
        field-ids))))

(define static-class->field-types
  (lambda (sc)
    (cases static-class sc
      (a-static-class
        (class-name super-name specifier  field-ids
          field-types methods)
        field-types))))

(define static-class->methods
  (lambda (sc)
    (cases static-class sc
      (a-static-class
        (class-name super-name specifier field-ids
          field-types methods)
        methods))))

(define static-method->method-name
  (lambda (sm)
    (cases static-method-struct sm
      (a-static-method-struct
        (method-name specifier type super-name)
        method-name))))

(define static-method->abstraction-specifier
  (lambda (sm)
    (cases static-method-struct sm
      (a-static-method-struct
        (method-name specifier type super-name)
        specifier))))

(define static-method->type
  (lambda (sm)
    (cases static-method-struct sm
      (a-static-method-struct
        (method-name specifier type super-name)
        type))))

(define static-method->super-name
  (lambda (sm)
    (cases static-method-struct sm
      (a-static-method-struct
        (method-name specifier type super-name)
        super-name))))

(define class-type->name
  (lambda (ty)
    (cases type ty
      (class-type (name) name)
      (else
        (eopl:error 'class-type->name
          "Not a class type: ~s" ty)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; The Compiler ;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The compiler reuses much of the type-checking
;; infrastructure, including type environments.
;; Type environments have the same shape as
;; run-tie environments, so we could use them to
;; compute lexical addresses.

;; translation-of-program : program -> program
(define translation-of-program
  (lambda (pgm)
    (let ((pgm-type (type-of-program pgm)))
      (cases program pgm
        (a-program (c-decls exp)
          (a-program
            (translation-of-class-decls c-decls)
            (translation-of-expression exp (empty-tenv))))))))

;; translation-of-expression : expression env -> expression
(define translation-of-expression
  (lambda (exp tenv)
    (cases expression exp
      ;;
      ;; Most of the time, translation does nothing immediate:
      ;;
      (lit-exp (number) exp)
      (true-exp () exp)
      (false-exp () exp)
      (var-exp (id) exp)  
      (primapp-exp (prim rands)
        (primapp-exp prim
          (translations-of-expressions rands tenv)))
      (if-exp (test-exp true-exp false-exp)
        (if-exp (translation-of-expression test-exp tenv)
          (translation-of-expression true-exp tenv)
          (translation-of-expression false-exp tenv)))
      (app-exp (rator rands) 
        (app-exp
          (translation-of-expression rator tenv)
          (translations-of-expressions rands tenv)))
      (let-exp (ids rands body)
        (translation-of-let-exp ids rands body tenv))
      (proc-exp (id-texps ids body)
        (translation-of-proc-exp id-texps ids  body tenv))
      (letrec-exp (result-texps proc-names id-texpss idss
                    bodies letrec-body) 
        (translation-of-letrec-exp
          result-texps proc-names id-texpss idss bodies
          letrec-body tenv))
      (varassign-exp (id rhs)     ;; more dull cases
        (varassign-exp id (translation-of-expression rhs tenv)))
      (begin-exp (exp1 exps)                
        (begin-exp
           (translation-of-expression exp1 tenv)
           (translations-of-expressions exps tenv)))
      (list-exp (exp1 exps) 
        (list-exp
           (translation-of-expression exp1 tenv)
           (translations-of-expressions exps tenv)))
      (cons-exp (car-exp cdr-exp)
        (cons-exp
          (translation-of-expression car-exp tenv)
          (translation-of-expression cdr-exp tenv)))
      (car-exp (exp1) 
        (car-exp (translation-of-expression exp1 tenv)))
      (cdr-exp (exp1) 
        (cdr-exp (translation-of-expression exp1 tenv)))
      (nil-exp (type-exp) exp)
      (null?-exp (exp1) 
        (null?-exp (translation-of-expression exp1 tenv)))
      (new-object-exp (class-name rands)
        (new-object-exp class-name
          (translations-of-expressions rands tenv)))
      (super-call-exp (msg rands) 
        (super-call-exp msg
          (translations-of-expressions rands tenv)))
      ;;
      ;; Translation does something interesting here:
      ;;
      (method-app-exp (obj-exp msg rands) 
        (translation-of-method-app-exp
          obj-exp msg rands tenv))
      (cast-exp (obj-exp name)
        (translation-of-cast-exp obj-exp name tenv))

      (else (eopl:error 'eval-expression
              "~%Illegal expression~%~s" exp)))))

;; translations-of-expressions : lstof-expr env -> lstof-expr
(define translations-of-expressions
  (lambda (exps tenv)
    (map (lambda (exp) (translation-of-expression exp tenv)) exps)))

;; translation-of-proc-exp : lstof-texpr lstof-sym expr tenv -> expr
;;  To translate a procedure, translate its body,
;;  and leave the arguments alone.
(define translation-of-proc-exp
  (lambda (id-texps ids body tenv)
    (let ((id-types (expand-type-expressions id-texps)))
      (proc-exp
        id-texps
        ids
        (translation-of-expression body
          (extend-tenv ids id-types tenv))))))

;; translation-of-let-exp : lstof-sym lstof-expr expr tenv -> expr
;;  Translates a `let' expression by translating the
;;  right-hand expressions and the body expression.
(define translation-of-let-exp
  (lambda (ids rands body tenv)
    (let ((tenv-for-body
            (extend-tenv
              ids
              (types-of-expressions rands tenv)
              tenv)))
      (let-exp
        ids
        (translations-of-expressions rands tenv)
        (translation-of-expression body tenv-for-body)))))

;; type-of-letrec-exp : lstof-type-expr lstof-sym lstof-lstof-type-expr 
;;                      lstof-lstof-sym lstof-expr expr tenv -> expr
;;  Translates a `letrec' expression by translating the
;;  right-hand expressions and the body expression.
(define translation-of-letrec-exp
  (lambda (result-texps proc-names id-texpss idss bodies
            letrec-body tenv)
    (let ((id-typess (map expand-type-expressions id-texpss))
          (result-types
            (expand-type-expressions result-texps)))
      (let ((the-proc-types
              (map proc-type id-typess result-types)))
        (let ((tenv-for-body ;; type env for body and all proc-bodies
                (extend-tenv proc-names the-proc-types tenv)))
          (letrec-exp result-texps proc-names id-texpss idss
            (map
              (lambda (id-types ids body)
                (translation-of-expression body 
                  (extend-tenv ids id-types tenv-for-body)))
              id-typess idss bodies)
            (translation-of-expression
              letrec-body
              tenv-for-body)))))))

;;;;;;;;;;;;;;;; code for class decls ;;;;;;;;;;;;;;;;

;; translation-of-class-decls : lstof-class-decl -> lstof-class-decl
;;  Translates a sequence of class declarations.
(define translation-of-class-decls
  (lambda (c-decls)
    (map translation-of-class-decl c-decls)))

;; translation-of-class-decls : class-decl -> class-decl
;;  Translates one class declaration by translating
;;  (non-abstract) method bodies.
(define translation-of-class-decl
  (lambda (c-decl)
    (cases class-decl c-decl
      (a-class-decl (specifier class-name super-name
                      local-field-texps local-field-ids
                      m-decls)
        (a-class-decl specifier class-name super-name
          local-field-texps local-field-ids
          (map
            (lambda (method-decl)
              (translation-of-method-decl method-decl
                class-name))
            m-decls))))))

;; translation-of-method-decl : meth-decl sym -> metho-decl
;;  Translates a single method declaration by translating
;;  its (non-abstract) method body.
(define translation-of-method-decl
  (lambda (m-decl class-name)
    (let ((class (statically-lookup-class class-name)))
      (let ((super-name (static-class->super-name class))
            (field-ids  (static-class->field-ids class))
            (field-types (static-class->field-types class)))
        (cases method-decl m-decl
          (a-method-decl (result-texp name id-texps ids body)
            (let ((id-types
                    (expand-type-expressions id-texps)))
              (let ((tenv
                      (extend-tenv
                        (cons '%super (cons 'self ids))
                        (cons (class-type super-name)
                          (cons (class-type class-name)
                            id-types))
                        (extend-tenv field-ids field-types
                          (empty-tenv)))))
                (a-method-decl
                  result-texp name id-texps ids
                  (translation-of-expression body tenv)))))
          (an-abstract-method-decl (result-texp name id-texps
                                    ids)
            m-decl))))))

;; translation-of-method-app-exp : expr sym lstof-expr tenv -> expr
;;  Translates a `send' expression, resolving the method name
;;  to a method position in the class.
(define translation-of-method-app-exp
  (lambda (obj-exp msg rands tenv)
    (let ((obj-type (type-of-expression obj-exp tenv)))
      (cases type obj-type
        (class-type (class-name)
          (let ((class (statically-lookup-class class-name)))
            (let ((pos
                    (list-index
                      (lambda (method)
                        (eqv?
                          msg
                          (static-method->method-name
                            method)))
                      (static-class->methods class))))
              (if (number? pos)
                (apply-method-indexed-exp
                  (translation-of-expression obj-exp tenv)
                  pos
                  (translations-of-expressions rands tenv))
                (eopl:error 'translation-of-method-app-exp
                  (string-append
                    "~%Shouldn't have gotten here: Class"
                    "~s has no method for ~s in ~%~s")
                  class-name
                  msg
                  (method-app-exp obj-exp msg rands))))))
        (else
          (eopl:error 'translation-of-method-app-exp
            (string-append
              "~%Shouldn't have gotten here:"
              " Can't send message to non-object"
              "~s in ~%~s")
            obj-type
            (method-app-exp obj-exp msg rands)))))))

;; translation-of-cast-exp : expr name tenv -> expr
;;  Translates a `cast' expression by eliminating the
;;  cast if it will obviously succeed.
(define translation-of-cast-exp
  (lambda (obj-exp name tenv)
    (let ((obj-type (type-of-expression obj-exp tenv))
          (obj-code (translation-of-expression obj-exp tenv)))
      (cases type obj-type
        (class-type (obj-class-name)
          (cond
            ((statically-is-subclass? obj-class-name name)
             ;; upcast -- nothing to do
             obj-code)
            ((statically-is-subclass? name obj-class-name)
             ;; downcast -- generate cast
             (cast-exp obj-code name))
            (else
              (eopl:error 'translation-of-cast-exp
                (string-append
                  "~%Shouldn't have gotten here:"
                  " ~s incomparable with ~s in ~%~s")
                obj-class-name
                name
                (cast-exp obj-exp name)))))
        (else
          (eopl:error 'translation-of-cast-expression
            (string-append
              "~%Shouldn't have gotten here:"
              "~s not an object type in ~%~s")
              obj-type
              (cast-exp obj-exp name)))))))

;;;;;;;;;;;;;;;; test programs ;;;;;;;;;;;;;;;;

(define fish-decls
  "class fish extends object
     field int size
     method void initialize (int s) set size = s
     method int get_size() size
     method void grow(int food)
       set size = +(size, food)
     method void eat(fish other_fish)
       let s = send other_fish get_size()
        in send self grow(s)

   class colorfish extends fish
     field int color
     method void set_color(int c) set color = c
     method int get_color() color
  
   class pickyfish extends fish
     method void grow(int food)
       super grow(-(food, 1))")

(define fish-program
  (string-append
   fish-decls
   "let p = new pickyfish(7)
        c = new colorfish(2)
     in begin
          send p eat(c);
          send p get_size()
        end"))

(define simple-program
  "class c1 extends object
     field int i
     field int j
     method void initialize (int x)
       begin
         set i = x;
         set j = -(0, x)
       end
     method void countup (int d)
       begin
         set i = +(i,d);
         set j = -(j,d)
       end
     method list int getstate () list(i,j)
     
   let t1 = nil[int]
       t2 = nil[int]
       o1 = new c1(3)
    in begin
         set t1 = send o1 getstate();
         send o1 countup(2);
         set t2 = send o1 getstate();
         list(t1,t2)
       end")

(define tree-program
  "abstract class tree extends object
     abstractmethod int sum()

   class interior_node extends tree
     field tree left
     field tree right
     method void initialize (tree l, tree r)
       begin
         set left = l;
         set right = r
       end
     method int sum () +(send left sum(), send right sum())
     
   class leaf_node extends tree
     field int value
     method void initialize (int v) set value = v
     method int sum () value
     
   let o1 = new interior_node(
              new interior_node(
                new leaf_node(3),
                new leaf_node(4)),
              new leaf_node(5))
    in send o1 sum()")

(define point-program
  "class point extends object
     field int x
     field int y
     method void initialize (int initx, int inity)
       begin
         set x = initx;
         set y = inity
       end
     method void move (int dx, int dy)
       begin
         set x = +(x, dx);
         set y = +(y, dy)
       end
     method list int get_location () list (x, y)
     
   class colorpoint extends point
     % Add a field and methods:
     field int color
     method void set_color (int c) set color = c
     method int get_color () color
     
   class doublepoint extends point
     % Override move:
     method void move (int dx, int dy)
       begin
         super move(+(dx,dx), +(dy,dy))
       end
       
   let p = new point(3, 4)
       cp = new colorpoint(10, 20)
       dp = new doublepoint(0, 0)
    in begin
         send p move(3, 4);
         send cp set_color(87);
         send cp move(10, 20);
         send dp move(6, 7);
         list(send p get_location(),     % (6 8)
              send cp get_location(),    % (20 40)
              list(send cp get_color()), % (87)
              send dp get_location())    % (12 14)
       end")

(define list-program
  "abstract class mylist extends object
    method int initialize() 0
    abstractmethod int sum()

   class link extends mylist
    field int val
    field mylist next
    method void initialize (int v, mylist n)
     begin
      super initialize();
      set val = v;
      set next = n
     end
    method int sum() +(val, send next sum())
  
   class null extends mylist
    method int initialize() super initialize()
    method int sum() 0

   letrec mylist mk(int n) =
                    if zero?(n) 
                       then cast new null() mylist
                       else cast new link(n, (mk -(n, 1))) mylist
    in send (mk 100) sum()")

;; For 200alpha1, change `#%collect-garbage' and `#%time'
;; to `collect-garbage' and `time'
(define (run-time-tests)
  (let ([p (scan&parse list-program)])
    (let ([p2 (translation-of-program p)])
      (eopl:printf "Original: ~n")
      (#%collect-garbage)
      (eopl:printf "Result = ~a~n" (#%time (eval-program p)))
      (eopl:printf "Translated: ~n")
      (#%collect-garbage)
      (eopl:printf "Result = ~a~n" (#%time (eval-program p2))))))