;;;; Jim Miller, March 30, 1997
;;;; Split JAVA-INTERP3 into JAVA-EVAL and JAVA-SUPPORT
;;;; Jim Miller, March 29, 1997
;;;; Added many comments, separated method and variable lookup, added
;;;; coercion on assignment and method call.
;;;; Jeremy Daniel, April 26, 1997
;;;; bug fixees and added limits for unparser depth and breadth so 
;;;; scheme would not loop forever while trying to print java environments
;;;; Jeremy Daniel, April 27, 1997 
;;;; made code that needs to be written by students into 
;;;; (error "java-working not loaded")

(define *unparser-list-depth-limit* 4)
(define *unparser-list-breadth-limit* 6)

;;; The evaluator dispatch point

(define (j-eval exp env next)
  ;; EXP is a Java-In-Scheme expression.
  ;; ENV is an environment (see abstraction below)
  ;; (NEXT value) is called when the value has been computed
  (cond
   ;; Expressions
   ((literal? exp) (j-eval-literal exp env next))
   ((variable? exp) (j-eval-variable exp env next))
   ((new? exp) (j-eval-new exp env next))
   ((dot? exp) (j-eval-dot exp env next))
   ((call? exp) (j-eval-call exp env next))
   ((cast? exp) (j-eval-cast exp env next))
   ((instanceof? exp) (j-eval-instanceof exp env next))
   ((built-in-expr? exp) (j-eval-built-in-expr? exp env next))
   ((assignment? exp) (j-eval-assignment exp env next))
   ;; Statements
   ((variables? exp) (j-eval-variables exp env next))
   ((if? exp) (j-eval-if exp env next))
   ((while? exp) (j-eval-while exp env next))
   ((do? exp) (j-eval-do exp env next))
   ((block? exp) (j-eval-block exp env next))
   ((label? exp) (j-eval-label exp env next))
   ((break? exp) (j-eval-break exp env next))
   ((continue? exp) (j-eval-continue exp env next))
   ((return? exp) (j-eval-return exp env next))
   ((for? exp) (j-eval-for exp env next))
   ;; Handle declarations specially
   ((global? exp) (j-eval-global exp env next))
   ((quick-class-test? exp)
    (let ((full-class (class? exp)))
      (if full-class
          (j-eval-class full-class env next)
          (error "Bad syntax for CLASS" exp env))))
   ((quick-interface-test? exp)
    (let ((full-interface (interface? exp)))
      (if full-interface
          (j-eval-interface full-interface env next)
          (error "Bad syntax for INTERFACE" exp env))))
   (else (error "Unknown type of expression" exp env))))

;;; Evaluator action routines

(define (j-eval-literal exp env next)
  (next
   (if (self-evaluating? exp)
       exp
       (case exp
	 ((NULL) '())
	 ((FALSE) #F)
	 ((TRUE) #T)))))

(define (j-eval-variable exp env next)
  (find-value exp env next))

(define (j-eval-new exp env next)
  ;; Simplified because we don't support explicit constructors for
  ;; Java classes.
  (let ((type (lookup-class (new.type exp))))
    (next ((if (predefined-class? type)
               type->default-value-expr
               make-object)
           type))))

(define (j-eval-dot exp env next)
  ;; (DOT <expr> <name> ...)
  (dot-binding exp env
    (lambda (binding)
      (next (binding.value binding)))))

(define (j-eval-call exp env next)
  ;; First, evaluate all of the operands
  (j-eval-in-order (call.operands exp) env
    (lambda (operands)
      ;; Then figure out the method to use from the name of the method,
      ;; the types of the arguments, and the current environment's base
      (method-lookup
       (call.operator exp) (map get-type operands) env
       (lambda (method object class)
         (let ((params (method.params method))
               (signature (method.signature method))
               (labels *labels*))
           (define (done val)
             ;; Called when the procedure exits to remove any labels
             ;; that were created after this point in time.
	     (let ((result-type-name
		    (signature.result-type signature)))
	       (set! *labels* labels)
	       (next
		(if (eq? 'VOID result-type-name)
		    '()
		    (coerce val (lookup-class result-type-name))))))
           ;; Create a label for use with RETURN
           (add-label! '*RETURN-LABEL* done)
           ;; Evaluate the body in a newly constructed environment.
           ;; Note the call to COERCE for the operator and the
           ;; operands.  When the body completes, call done to remove
           ;; labels and exit.
           (j-eval (method.body method)
                   (extend-environment
                    (make-frame 'BINDINGS
                                (make-bindings
                                 (map parameter.name params)
                                 (map parameter.type params)
                                 (map coerce
				      (map get-self operands)
                                      (map lookup-class
                                           (signature.arg-types
					    signature)))))
                    (basic-environment
                     (if (static-method? method)
                         class
                         (coerce (object.this object) class))))
                   done)))))))

(define (j-eval-cast exp env next)
  ;; (CAST <type> <expr>)
  (let ((type (lookup-class (cast.type exp))))
    (j-eval (cast.expr exp) env
      (lambda (value)
        (next (coerce (object.this value) type))))))

(define (j-eval-instanceof exp env next)
  (let ((type (lookup-class (instanceof.type exp))))
    (j-eval (instanceof.expr exp) env
      (lambda (obj)
        (define (loop current)
          (or (eq? current type)
              (and (not (eq? current *object*?))
                   (loop (ev-class.superclass current)))))
        (cond ((null? obj)
               ;; The value VOID responds "false" to any instance-of
               ;; question.  ***IS THIS CORRECT?***
               (next #F))
              ((predefined-class? type) (next (type obj)))
              ((and (pair? obj)
                    (eq? (car obj) 'OBJECT))
               ;; Instance of a user class.  Walk back the chain of
               ;; classes, starting at the true class of the object
               (next (loop (object.class (object.this obj)))))
              (else (next #F)))))))

(define (j-eval-built-in-expr? exp env next)
  (define (and-loop exps)
    (if (null? exps)
        (next #T)
        (j-eval (car exps) env
                (lambda (val)
                  (cond ((eq? val #T)
                         (and-loop (cdr exps)))
                        ((eq? val #F)
                         (next #F))
                        (else (error "AND: Not a boolean value")))))))
  (define (or-loop exps)
    (if (null? exps)
        (next #F)
        (j-eval (car exps) env
                (lambda (val)
                  (cond ((eq? val #T)
                         (next #T))
                        ((eq? val #F)
                         (or-loop (cdr exps)))
                        (else (error "OR: Not a boolean value")))))))
  (define (qm exps)
    (j-eval (first exps) env
            (lambda (pred)
              (cond ((eq? pred #T)
                     (j-eval (second exps) env next))
                    ((eq? pred #F)
                     (j-eval (third exps) env next))
                    (else (error "?: Not a boolean value"))))))

  (let ((operator (built-in.operator exp)))
    (let ((op (operator.scheme (assq operator operators)))
          (rands (built-in.operands exp)))
      (if op
          (j-eval-in-order rands env
            (lambda (evaluated-rands)
              (next (apply op evaluated-rands))))
          ((case (first exp)
             ((AND) and-loop)
             ((OR)  or-loop)
             ((?)   qm)) rands)))))

(define (j-eval-assignment exp env next)
  ;; (<assignment operator> <assignable> <expr>)
  (let ((op (assq (assignment.operator exp) assignments))
        (assignable (assignment.assigned exp))
        (expr (assignment.value exp)))
    (let ((scheme-op (assign-op.rewrite op)))
      ;; Find the binding that must be changed.  This might be a
      ;; normal variable reference (FIND-BINDING) or the result of a
      ;; DOT expression (DOT-BINDING).
      ((if (java-name? assignable)
           find-binding dot-binding) assignable env
       (lambda (binding)
         (let ((type (lookup-class (binding.type-name binding))))
           ;; Evaluate the expression part
           (j-eval expr env
            (lambda (val)
              ;; With the right hand side known, do the Scheme
              ;; operation on it to combine it with the old value,
              ;; then coerce the result to the desired type and store
              ;; it back.
              (let ((final
                     (coerce
                      ;; Note: we do NOT use object.this here!
                      (scheme-op (binding.value binding) val)
                      type)))
                (set-binding.value! binding final)
                ;; Assignment returns the new value in Java.
                (next final))))))))))

(define (j-eval-variables exp env next)
  (error "java-working not loaded")
; comment out above line once you've filled in code
  ;; Moved to JAVA-WORKING

  ;; (VARIABLES <type> (<VariableDecl> ...) <statement>)
  (let ((vdecls (variables.var-decls exp))
        (type-name (variables.type exp)))
    (let ((names (map var-decl.name vdecls))
          (type (lookup-class type-name))
          (init-exprs
           (map (get-initializer type-name) vdecls)))
      ;; INIT-EXPRS is a list of Java-in-Scheme expressions that must
      ;; be evaluated to initialize the new variables.
      (j-eval-in-order init-exprs env
        (lambda (init-vals)
          ;; Extend the environment by creating bindings for the new
          ;; variables (including "assignment conversion" of the
          ;; values), and then in this extended environment evaluate
          ;; the statement.
	  .......... YOUR CODE HERE ...........)))))

(define (j-eval-global exp env next)
  ;; (GLOBAL <type> <VariableDecl> ...)
  (if (not (eq? env the-global-environment))
      (error "GLOBAL only allowed at top level"))
  (let ((vdecls (global.decls exp))
        (type-name (global.type exp)))
    (let ((names (map var-decl.name vdecls))
          (type (lookup-class type-name))
          (inits (map (get-initializer type-name) vdecls)))
      ;; INITS is a list of Java-in-Scheme expressions that must be
      ;; evaluated to initialize the new variables.
      (j-eval-in-order inits env
        (lambda (initial-values)
          ;; Now define each new name to have the coerced computed
          ;; value.
          (for-each
           (lambda (name init)
             (define-global! name type-name (coerce init type)))
           names initial-values)
          (next "Defined"))))))

(define (j-eval-if exp env next)
  ;; (IF <test> <consequent> <alternative>)
  (j-eval (if.predicate exp) env
    (lambda (pred)
      (cond ((eq? pred #T)
             (j-eval (if.consequent exp) env next))
            ((eq? pred #F)
             (j-eval (if.alternative exp) env next))
            (else (error "IF: Not a boolean value"))))))

(define (j-eval-while exp env next)
  ;; (WHILE <boolean expr> <statement>)
  (let ((labels *labels*)
        (bool-expr (while.predicate exp))
        (statement (while.statement exp)))
    (define (done)
      (set! *labels* labels)
      (next "End of WHILE"))
    (define (again)
      ;; Val is ignored
      (j-eval bool-expr env
        (lambda (bool)
          (cond ((eq? bool #T)
                 (j-eval statement env
		   (lambda (ignored-value) (again))))
                ((eq? bool #F) (done))
                (else (error "WHILE: Not a boolean value"))))))
    (add-label! '*BREAK-LABEL* done)
    (add-label! '*CONTINUE-LABEL* again)
    (again)))

(define (j-eval-do exp env next)
  (error "java-working not loaded")
; comment out above line once you've filled in code
  ;; Moved to JAVA-WORKING
  ...)

(define (j-eval-block exp env next)
  ;; (BLOCK <statement> ...)
  (define (loop exprs)
    (if (null? exprs)
        (next "End of block")
        (j-eval (car exprs) env
                (lambda (val) (loop (cdr exprs))))))
  (loop (cdr exp)))

(define (j-eval-label exp env next)
  ;; (LABEL <name> <statement>)
  (let ((name (label.name exp))
        (labels *labels*))
    (define (return-here)
      (set! *labels* labels)
      (next "End of labelled block"))
    (add-label! name return-here)
    (j-eval (label.statement exp) env
            (lambda (val) (return-here)))))

(define (j-eval-break exp env next)
  ;; (BREAK) or (BREAK <name>)
  (exit exp '*BREAK-LABEL*))

(define (j-eval-continue exp env next)
  ;; (CONTINUE) or (CONTINUE <name>)
  (exit exp '*CONTINUE-LABEL*))

(define (j-eval-return exp env next)
  ;; (RETURN) or (RETURN <expr>)
  (define (finish val)
    ((lookup-label '*RETURN-LABEL*) val))
  (if (null? (list-tail exp 1))
      (finish "No value specified")
      (j-eval (second exp) env finish)))

(define (j-eval-for exp env next)
  ;; (FOR <init expr> <boolean expr> <next statement> <statement>)
  ;; <init expr> is either <statement> or (<type> <var-decl> ...)
  (let ((init (for.initialize exp))
        (bool (for.predicate exp))
        (next-statement (for.update exp))
        (statement (for.statement exp))
        (labels *labels*))
    (define (finish)
      (set! *labels* labels)
      (next "End of FOR"))
    (define (do-the-loop env)
      (define (test val)
        (j-eval bool env
                (lambda (bool)
                  (cond ((eq? bool #T) (body))
                        ((eq? bool #F) (finish))
                        (else (error "FOR: Not a boolean value"))))))
      (define (body)
        (j-eval statement env next-state))
      (define (next-state val)
        (j-eval next-statement env test))
      (add-label! '*BREAK-LABEL* finish)
      (add-label! '*CONTINUE-LABEL* next-state)
      (test 'ignore))
    (if (statement? init)
        (j-eval init env (lambda (ignore) (do-the-loop env)))
        (let ((type-name (car init)))
          (let ((->init (get-initializer type-name))
                (type (lookup-class type-name))
                (var-decls (list-tail init 1)))
            ;; Calculate the initial values of the new variables
            (j-eval-in-order
             (map ->init var-decls) env
             (lambda (computed-values)
               ;; Build a new environment with the new variables in it
               (do-the-loop
                (extend-environment
                 (make-frame 'FOR
                  (make-bindings
                   (map var-decl.name var-decls)
                   (map (lambda (var-decl) type-name) var-decls)
                   (map (lambda (val) (coerce val type)) computed-values)))
                 env)))))))))

(define (j-eval-class full-class env next)
  (define (split test? list continue)
    ;; Split the LIST into two parts based on applying TEST? to each
    ;; element.  Returns by calling (CONTINUE YESes NOs).
    (define (loop yes no maybe)
      (cond ((null? maybe)
             (continue (reverse yes) (reverse no)))
            ((test? (car maybe))
             (loop `(,(car maybe) ,@yes) no (cdr maybe)))
            (else (loop yes `(,(car maybe) ,@no) (cdr maybe)))))
    (loop '() '() list))

  (define (field->init-exprs field)
    ;; Given a FIELD expression, return expressions to initialize the
    ;; fields it declares 
    (map (get-initializer (field.type field))
         (field.var-decls field)))

  (let ((name (class.name full-class))
        (super (lookup-class (class.extends full-class)))
        (ifaces (map lookup-class (class.implements full-class)))
        (body-forms (class.body-forms full-class)))
    ;; Separate out the body-forms into methods, static (class)
    ;; fields, dynamic (object) fields, and initializers, so these
    ;; sublists can be handled independently.
    (split
     quick-method-test? body-forms
     (lambda (methods rest)
       (split
        quick-field-test? rest
        (lambda (fields initializers)
          (split
           static-field? fields
           (lambda (class-fields object-fields)
             ;; Now pull out the various sub-parts of these body
             ;; forms, like the names, types, and initializers for
             ;; each kind of part.
             (let ((method-names (map method.name methods))
                   (method-signatures (map method.signature methods))
                   (class-field-names
                    (flatten (map field->var-names class-fields)))
                   (obj-field-names
                    (flatten (map field->var-names object-fields)))
                   (class-field-type-names
                    (flatten (map field->type-names class-fields)))
                   (obj-field-type-names
                    (flatten (map field->type-names object-fields)))
                   (obj-field-vals
                    (flatten (map field->init-exprs object-fields))))
               ;; Calculate the initial values of the class's (static)
               ;; fields.
               (j-eval-in-order
                (flatten (map field->init-exprs class-fields))
                the-global-environment
                (lambda (class-field-vals)
                  ;; Create the CLASS object
                  (let ((class
                         (make-ev-class name super ifaces
                          (make-bindings method-names
                                         method-signatures
                                         methods)
                          (make-bindings class-field-names
                           class-field-type-names
                           (map (lambda (val type) (coerce val type))
                                class-field-vals
                                (map lookup-class class-field-type-names)))
                          (make-bindings obj-field-names
                                         obj-field-type-names
                                         obj-field-vals))))
                    ;; Make the class known as a data type name
                    (add-class! name class)
                    ;; Run the initialization for the class
                    (if (null? initializers)
                        (next class)
                        (j-eval
                         `(BLOCK ,@initializers)
                         (basic-environment class)
                         (lambda (ignore)
                           (next class))))))))))))))))

(define (j-eval-interface full-interface next) ...)