;; Basic interpreter for a language with classes.

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

;; An object is a list of parts

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

(define init-env 
  (lambda () (empty-env)))

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

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

(define-datatype part part? 
  (a-part
    (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)
    (if (eqv? class-name 'object)
      '()
      (let ((c-decl (lookup-class class-name)))
        (cons
          (make-first-part c-decl)
          (new-object (class-decl->super-name c-decl)))))))

;; make-first-part : class-decl -> part
;;  Creates a portion of an object, a part corresponding
;;  to a single class extension.
(define make-first-part
  (lambda (c-decl)
    (a-part
      (class-decl->class-name c-decl)
      (make-vector (length (class-decl->field-ids c-decl))))))

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

;; find-method-and-apply : sym sym object list-of-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)
    ;; If host-name is 'object, we didn't find the method
    (if (eqv? host-name 'object)
	(eopl:error 'find-method-and-apply
		    "No method for name ~s" m-name)
	;; Look inthe specified class
	(let ((m-decl (lookup-method-decl
		       m-name
		       (class-name->method-decls host-name))))
	  ;; If method-decl? is #f, it wasn't found
	  (if (method-decl? m-decl)
	      ;; It was found: apply the method
	      (apply-method m-decl host-name self args)
	      ;; Not found; look in superclass
	      (find-method-and-apply 
	       m-name 
	       (class-name->super-name host-name)
	       self args))))))

;; view-object-as : object sym -> list-of-parts
;;  Given an object and a class name, extracts a list of parts
;;  corresponding to just that class (not any subclasses)
(define view-object-as
  (lambda (parts class-name)
    (if (eqv? (part->class-name (car parts)) class-name)
	parts
	(view-object-as (cdr parts) class-name))))

;; apply-method : method-decl sym object list-of-expval -> expval
;;  Given a method declaration, 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 (m-decl host-name self args)
    (let ((ids (method-decl->ids m-decl))
          (body (method-decl->body m-decl))
          (super-name (class-name->super-name host-name)))
      (eval-expression 
       body
       ;; Start with the environment containg class
       ;; fields, then add self and super
       (extend-env
	(cons '%super (cons 'self ids))
	(cons super-name (cons self args))
	(build-field-env 
	 (view-object-as self host-name)))))))

;; build-field-env : list-of-parts -> env
;;  Given a list of parts, creates an environment
;;  containing the part slots as variable bindings.
(define build-field-env
  (lambda (parts)
    (if (null? parts)
	(empty-env)
	(extend-env-refs
	 (part->field-ids (car parts))
	 (part->fields    (car parts))
	 (build-field-env (cdr parts))))))

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

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

(define the-class-env '())

;; elaborate-class-decls! : list-of-class-decls ->
;;  Remembers a set of class declarations for use later.
(define elaborate-class-decls!
  (lambda (c-decls)
    (set! the-class-env c-decls)))

;; lookup-class : sym -> class-decl
;;  Finds a remembered class declaration
(define lookup-class
  (lambda (name)
    (let loop ((env the-class-env))
      (cond
        ((null? env)
         (eopl:error 'lookup-class
           "Unknown class ~s" name))
        ((eqv? (class-decl->class-name (car env)) name) (car env))
        (else (loop (cdr env)))))))

;;;;;;;;;;;;;;;; selectors of all sorts ;;;;;;;;;;;;;;;;

(define part->class-name
  (lambda (prt)
    (cases part prt
      (a-part (class-name fields)
        class-name))))

(define part->fields
  (lambda (prt)
    (cases part prt
      (a-part (class-name fields)
        fields))))

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

(define part->class-decl
  (lambda (part)
    (lookup-class (part->class-name part))))

(define part->method-decls
  (lambda (part)
    (class-decl->method-decls (part->class-decl part))))

(define part->super-name
  (lambda (part)
    (class-decl->super-name (part->class-decl part))))

(define class-name->method-decls
  (lambda (class-name)
    (class-decl->method-decls (lookup-class class-name))))

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

(define object->class-name
  (lambda (parts)
    (part->class-name (car parts))))

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

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