;; Interpreter with flat objects and pre-processed class trees.
;; Changes from previous interpreter are marked with >>>.

;; 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 ;;;;;;;;;;;;;;;;

(define run
  (lambda (string)
    (eval-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)

    ;; Class declarations ----------------------------------------

    (class-decl                         
      ("class" identifier 
        "extends" identifier                   
         (arbno "field" identifier)
         (arbno method-decl)
         )
      a-class-decl)

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

    ;; Expressions using classes -----------------------------------

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

    ;; Basic expressions and primitives -------------------------

    (expression (number) lit-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 identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression
      ("letrec"
        (arbno identifier "(" (separated-list identifier ",") ")"
          "=" expression)
        "in" expression)
      letrec-exp)
    (expression ("set" identifier "=" expression) varassign-exp)
    (expression
      ("begin" expression (arbno ";" expression) "end")
      begin-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)
    (primitive ("list") list-prim)
    (primitive ("cons") cons-prim)
    (primitive ("nil")  nil-prim)
    (primitive ("car")  car-prim)
    (primitive ("cdr")  cdr-prim)
    (primitive ("null?") null?-prim)))

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

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

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

;; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (c-decls exp)
        (elaborate-class-decls! c-decls)
        (eval-expression exp (empty-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))
      (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 (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 (proc-names idss bodies letrec-body)
        (eval-expression letrec-body
          (extend-env-recursively proc-names idss bodies env)))
      (varassign-exp (id rhs-exp)
        (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)))))

      ;; Expressions using classes ------------------------------
      (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))))))
      

(define eval-rands
  (lambda (exps env)
    (map
      (lambda (exp) (eval-expression exp env))
      exps)))

(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))
      (list-prim () args)  ; already a list
      (nil-prim () '())
      (car-prim () (car (car args)))
      (cdr-prim () (cdr (car args)))
      (cons-prim () (cons (car args) (cadr args)))
      (null?-prim () (if (null? (car args)) 1 0)))))

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

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

;;;;;;;;;;;;;;;; declarations ;;;;;;;;;;;;;;;;

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

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

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

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

(define method-decl->method-name
  (lambda (md)
    (cases method-decl md
      (a-method-decl (method-name ids body) method-name))))

(define method-decl->ids
  (lambda (md)
    (cases method-decl md
      (a-method-decl (method-name ids body) ids))))

(define method-decl->body
  (lambda (md)
    (cases method-decl md
      (a-method-decl (method-name ids body) body))))

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

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

;; apply-procval : procval list-of-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 : list-of-sym list-of-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 : list-of-sym list-of-list-of-sym
;;                          list-of-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 : list-of-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))))

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

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

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

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

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

;;;;;;;;;;;;;;;; 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 (roll-up-field-length class-name)))))

(define roll-up-field-length            
  (lambda (class-name)
    (if (eqv? class-name 'object)
      0
      (+ (roll-up-field-length
          (class-name->super-name class-name))
         (length (class-name->field-ids class-name))))))

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

;; >>> Now we distinguish *classes* from *class declarations* <<<
;; Elaboration constructs class record from the tree of class
;; declarations in the original program.

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

(define elaborate-class-decls!
  (lambda (c-decls)
    (for-each elaborate-class-decl! c-decls)))

;; elaborate-class-decl! : class-decl -> 
;; Register one class from one class declaration.
(define elaborate-class-decl!
  (lambda (c-decl)
    (let ((super-name (class-decl->super-name c-decl)))
      (let ((field-ids  (append
                          (class-name->field-ids super-name)
                          (class-decl->field-ids c-decl))))
        (add-to-class-env!
          (a-class
            (class-decl->class-name c-decl)
            super-name
            (length field-ids)
            field-ids
            (roll-up-method-decls c-decl super-name field-ids)))))))

;; Flattens a class's methods into one list
(define roll-up-method-decls
  (lambda (c-decl super-name field-ids)
    (let ((super-name (class-decl->super-name c-decl)))
      (merge-methods
        (class-name->methods super-name)
        (map
          (lambda (m-decl)
            (a-method m-decl super-name field-ids))
          (class-decl->method-decls c-decl))))))

;; merge-methods : list-of-meth list-of-meth -> list-of-meth
;; Drops overridden methods while merging.
(define merge-methods
  (lambda (super-methods methods)
    (cond
      ((null? super-methods) methods)
      (else
        (let ((overriding-method
               (lookup-method
                (method->method-name (car super-methods))
                methods)))
          (if overriding-method
              (cons overriding-method
                    (merge-methods 
                     (cdr super-methods)
                     (remove-method overriding-method methods)))
              (cons (car super-methods)
                    (merge-methods 
                     (cdr super-methods)
                     methods))))))))

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

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

;; >>> We also distinguish *methods* from *method declarations* <<<

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

;; >>> find-method-and-apply no longer has to
;; search the class declaration tree <<<
(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 host-name self args)
          (eopl:error 'find-method-and-apply
                      "No method for name ~s" m-name)))))

(define apply-method                    
  (lambda (method host-name self args)
    (eval-expression 
     (method->body method) 
     (extend-env
      (cons '%super (cons 'self (method->ids method))) 
      (cons
       (method->super-name method) ;; 6-4-4
       (cons self args))
      (extend-env-refs         
       (method->field-ids method) 
       (object->fields self)
       (empty-env))))))

(define env-find-position               
  (lambda (name symbols)
    (list-find-last-position name symbols)))

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

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

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

;; >>> We now use the list of classes (not class decls) <<<

(define the-class-env '())

(define add-to-class-env!
  (lambda (class)
    (set! the-class-env (cons class the-class-env))))

(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 of all sorts ;;;;;;;;;;;;;;;;

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

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

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

   class colorfish extends fish
     field color
     method set_color(c) set color = c
     method get_color() color
  
   class pickyfish extends fish
     method grow(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 i
     field j
     method initialize (x)
       begin
         set i = x;
         set j = -(0, x)
       end
     method countup (d)
       begin
         set i = +(i,d);
         set j = -(j,d)
       end
     method getstate () list(i,j)
     
   let t1 = 0
       t2 = 0
       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
  "class interior_node extends object
     field left
     field right
     method initialize (l, r)
       begin
         set left = l;
         set right = r
       end
     method sum () +(send left sum(), send right sum())
     
   class leaf_node extends object
     field value
     method initialize (v) set value = v
     method 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 x
     field y
     method initialize (initx, inity)
       begin
         set x = initx;
         set y = inity
       end
     method move (dx, dy)
       begin
         set x = +(x, dx);
         set y = +(y, dy)
       end
     method get_location () list (x, y)
     
   class colorpoint extends point
     % Add a field and methods:
     field color
     method set_color (c) set color = c
     method get_color () color
     
   class doublepoint extends point
     % Override move:
     method move (dx, 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)
              send cp get_color(),    % 87
              send dp get_location()) % (12 14)
       end")