;;;; 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 27, 1997 
;;;; made code that needs to be written by students into 
;;;; (error "java-working not loaded")

;;; Top Level Read/Eval/Print Loop

(define input-prompt ";;; J-Eval input:")
(define output-prompt ";;; J-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (j-eval input the-global-environment
      (lambda (output)
        (announce-output output-prompt)
        (user-print output)
        (driver-loop)))))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define (initialize-java-environment)
  (set! *classes*
        (list (make-binding 'number    'CLASS number?)
              (make-binding 'string    'CLASS string?)
              (make-binding 'boolean   'CLASS boolean?)
              (make-binding 'char      'CLASS char?)
              (make-binding 'class     'CLASS *class*?)
              (make-binding 'interface 'CLASS *interface*?)
              (make-binding 'object    'CLASS *object*?)))
  (set! *labels* '())
  (set! the-global-environment
        (basic-environment
         (make-frame 'GLOBAL '())))
  'CLEARED)

(define (go . exprs)
  (initialize-java-environment)
  (for-each
   (lambda (expression)
     (j-eval expression the-global-environment user-print)
     (newline))
   exprs)
  (driver-loop))

;;; Data Abstractions

;; An object has four parts:
;; object.fields: dynamic fields as a list of bindings
;; object.class: its immediate class
;; object.superobject: its superobject if any
;; object.this:  THIS

;; NOTE: an object is a type of FRAME, so the frame abstraction works
;; on it as well!

(define (make-object class)
  (define (set-object.fields! obj frame)
    ;; Must be compatible with FRAME abstraction
    (set-car! (list-tail obj 1) frame))
  (define (set-object.superobject! obj super)
    (set-car! (list-tail obj 3) super))
  (define (set-object.this! obj this)
    (set-car! (list-tail obj 4) this))
  (define (insert-fields! class object)
    ;; OBJECT comes in complete except for the bindings that will be
    ;; created and inserted into it.
    (define (insert-fields-from-user-class! class object)
      (let ((class-info (ev-class.object-fields class)))
        ;; The values in the OBJECT-FIELDS have J-I-S expressions that
        ;; are used to initialize the object.
        (let ((bindings
               (map make-binding
                    (map binding.name class-info)
                    (map binding.type-name class-info)
                    (map (lambda (binding)
                           'THIS-SLOT-NOT-INITIALIZED-YET)
                         class-info)))
              (env (basic-environment object)))
          ;; Copy the bindings from the class to the object, but not
          ;; yet initialized
          (set-object.fields! object bindings)
          ;; Now evaluate the expressions and store the values in the
          ;; object's binding area.
          (for-each
           (lambda (class me)
             (j-eval (binding.value class) env
                     (lambda (value)
                       (set-binding.value! me value))))
           class-info bindings))))

    ;; body of insert-fields!
    (cond ((eq? class *object*?)
           ;; Real JAVA has some slots in the class Object
           (set-object.fields! object '()))
          ((predefined-class? class)
           (error "Inheriting form predefined class other than OBJECT"))
          (else (insert-fields-from-user-class! class object))))

  ;; Here's how to make an object:
  (let ((this (make-frame 'OBJECT 'FIELDS class 'SUPEROBJECT 'THIS)))
    (set-object.this! this this)
    (set-object.superobject! this
     (if (eq? class *object*?)
         #F
         (let ((superclass (ev-class.superclass class)))
           (let ((superobject (make-object superclass)))
             (set-object.this! superobject this)
             superobject))))
    (insert-fields! class this)
    this))

(define (object.fields obj)
  ;; This is the same as frame.bindings when the object is considered
  ;; to be a FRAME.  It is a list of bindings for the direct dynamic
  ;; fields of the object.
  (second obj))
(define (object.class obj) (third obj))
(define (object.superobject obj) (fourth obj))
(define (object.this obj) (fifth obj))
(define (object? x)
  (and (pair? x)
       (eq? (car x) 'OBJECT)))

;; An Evaluator Class (EV-CLASS) is a subtype of FRAME, constraining
;; its layout.

(define (make-ev-class name super implements
                       methods class-fields object-fields)
  ;; METHODS has entries for static and dynamic methods.
  ;;
  ;; CLASS-FIELDS has entries for static fields only.  It also has an
  ;; entry for the class itself.  When seen as a FRAME, CLASS-FIELDS is
  ;; the value returned by frame.bindings.
  ;;
  ;; OBJECT-FIELDS has the regular (non-static) fields. They are
  ;; stored as a list of bindings whose values are really expressions
  ;; to be evaluated when an object of this type is created.

  (make-frame 'CLASS class-fields name
              super implements methods object-fields))

(define (ev-class? obj)
  (and (pair? obj)
       (eq? (car obj) 'CLASS)))

(define (ev-class.class-fields class)
  ;; Same as FRAME.BINDINGS on the class.
  (second class))
(define (ev-class.name class) (third class))
(define (ev-class.superclass class) (fourth class))
(define (ev-class.implements class) (fifth class))
(define (ev-class.methods class) (sixth class))
(define (ev-class.object-fields class)
  ;; A list of bindings, but just the dynamic fields of the class
  (seventh class))

(Define (interface.name iface) ...)
(define (interface.implements iface) ...)
(define (interface.frame iface) ...)

;; An Interface should be defined here, but isn't ...

;; Environments are a list of frames that ends in a "Basic
;; environment" which is a singleton list of either a CLASS,
;; INTERFACE, GLOBAL, or OBJECT frame.

(define (basic-environment frame)
  (if (and (pair? frame)
           (memq (car frame)
                 '(CLASS INTERFACE GLOBAL OBJECT)))
      (extend-environment frame the-empty-environment)
      (error "Bad basic environment")))

(define (extend-environment new-frame environment)
  (cons new-frame environment))

(define (first-frame env) (car env))
(define (rest-of-frames env) (cdr env))
(define the-empty-environment '())

(define (environment.base environment)
  (if (null? environment)
      (error "No basic environment")
      (let ((frame (first-frame environment)))
        (case (first frame)
          ((BINDINGS FOR VARIABLES)
           (environment.base (rest-of-frames environment)))
          ((CLASS GLOBAL INTERFACE OBJECT) frame)
          (else (error "Bad environment frame"))))))

;; Frames have a tag (BINDINGS, CLASS, FOR, GLOBAL, INTERFACE, OBJECT,
;; VARIABLES) and an a-list of bindings.  They may optionally have
;; additional information.

;; There are three sub-types of frames: CLASS, OBJECT, and INTERFACE,
;; all defined above.  The structure of these must conform to the
;; structure of a FRAME (tag and bindings in the same place).

(define (make-frame tag bindings . stuff)
  `(,tag ,bindings ,@stuff))
(define (frame.tag frame) (first frame))
(define (frame.bindings frame) (second frame))
(define (frame.extra frame) (list-tail frame 2))

(define (frame.names frame)
  (map binding.name (frame.bindings frame)))
(define (frame.type-names frame)
  (map binding.type-name (frame.bindings frame)))
(define (frame.values frame)
  (map binding.value (frame.bindings frame)))

;; Bindings have a name, the name of a type, and a value. Only the
;; value can be changed.  A list of BINDINGS must be an A-LIST so that
;; it can be used with ASSQ.

(define (make-binding name type-name value)
  (list name type-name value))
(define (binding.name b) (first b))
(define (binding.type-name b) (second b))
(define (binding.value b) (third b))
(define (set-binding.value! b value)
  (set-car! (list-tail b 2) value))

(define (make-bindings names type-names values)
  (map make-binding names type-names values))

;;; Coercion

(define (coerce value type)
  (define (loop object)
    (cond ((eq? (object.class object) type)
           object)
          ((not (object.superobject object))
           (error "Can't cast to new type" value type))
          (else (loop (object.superobject object)))))
  (cond ((predefined-class? type)
         (if (type value)
             value
             (error "Can't cast to a predefined type")))
        ((null? value)
         ;; We aren't trying to produce a predefined type of
         ;; object, so NULL is always allowed as the value.
         value)
        ((and (pair? value)
              (eq? (car value) 'OBJECT))
         ;; Start at the objects real class and walk back to
         ;; find the class to which we're trying to cast it.
         (loop value))
        (else (error "Can't coerce a non-Reference value"))))

;;; Variable lookup

(define (find-binding var env next)
  ;; This searches only the runtime bindings created by calling
  ;; methods and the fields (not methods) from classes and interfaces.
  (let ((the-object #F))
    (define (loop env)
      (let ((frame (first-frame env)))
        (let ((entry (assq var (frame.bindings frame))))
          (or entry
              (case (first frame)
                ((BINDINGS FOR VARIABLES)
                 ;; Simplest case: try the next frame in the chain
                 (loop (rest-of-frames env)))
                ((GLOBAL)
                 ;; Base case 1: Global environment, variable not found
                 #F)
                ((CLASS)
                 ;; Base case 2: Class, first look at the interfaces,
                 ;; then either the superclass or the superobject
                 (or
                  (any loop
                       (map basic-environment (ev-class.implements frame)))
                  (let ((super (if the-object
                                   (object.superobject the-object)
                                   (ev-class.superclass frame))))
                    (and super
                         (not (predefined-class? super))
                         (loop super)))))
                ((INTERFACE)
                 ;; Base case 3: Interface, look at inherited interfaces
                 (any loop (map basic-environment
                                (interface.implements frame))))
                ((OBJECT)
                 ;; Base case 4: Object, look at the class, but
                 ;; remember that we've found an object so that parent
                 ;; dynamic fields are considered as we go up the
                 ;; chain of superclasses
                 (set! the-object frame)
                 (loop (basic-environment (object.class the-object)))))))))
    (let ((result (loop env)))
      (if result
          (next result)
          (error "Variable not found" var)))))
  
(define (dot-binding dot-expr env answer)
  ;; (DOT <expr> <name> ...)
  ;; Note: <expr> can be the special word THIS or SUPER
  (define (loop obj names)
    (if (not (*object*? obj))
        (error "DOT: value isn't a JAVA reference object" obj))
    (let ((next (car names))
          (rest (cdr names)))
      (find-binding next (basic-environment obj)
       (lambda (binding)
         (if (null? rest)
             (answer binding)
             (loop (binding.value binding) rest))))))

  (let ((expr (dot.expr dot-expr))
        (names (dot.names dot-expr)))
    (case expr
      ((THIS)
       (let ((base (environment.base env)))
         (if (not (eq? (frame.tag base) 'OBJECT))
             (error "THIS not allowed outside dynamic methods")
             (loop base names))))
      ((SUPER)
       (let ((base (environment.base env)))
         (if (not (eq? (frame.tag base) 'OBJECT))
             (error "SUPER not allowed outside dynamic methods"))
         (let ((super (object.superobject base)))
           (if super
               (loop super names)
               (error "No SUPER object found" base)))))
      (else (j-eval expr env (lambda (obj) (loop obj names)))))))

(define (find-value var env next)
  (find-binding var env
    (lambda (binding)
      (next (binding.value binding)))))

;;; Method lookup

(define (supertype-loop desired-type type count)
  (error "java-working not loaded")
; comment out above line once you've filled in code
  ;; Moved to JAVA-WORKING

  ;; Returns 0 for same type, 1 for one step away, etc., or #F
  ;; if type-name isn't a supertype of type
  (if (eq? type desired-type)
      ...      (let ((super (ev-class.superclass type)))
	(if (ev-class? super)
	    ...
	    ...))))

(define (decide new best decision)
  (error "java-working not loaded")
; comment out above line once you've filled in code
  ;; Moved to JAVA-WORKING

  ;; We start out TIEd, and only change that if we find
  ;; something definitely better or definitely worse.  If we
  ;; have to change our mind from NO to YES (or vice versa)
  ;; then it's really a TIE.
  ...)

(define (method-lookup method-name arg-types env next)
  ;; METHOD-NAME is either a simple Java name or (DOT ...)
  ;;
  ;; NEXT will be called with the method itself, the object (if any)
  ;; to which that method belongs, and the class in which the method
  ;; was found.
  
  (define (find-best-method
	   object all-methods signatures classes)
    ;; Calculate the "distance" for all of the methods to the
    ;; arguments, complain if there's an ambiguity, and call (NEXT
    ;; method object class) to return the values to the caller.
    (define (method-loop rest rest-sigs rest-classes
			 best-method best-dist best-class)
      (define (get-distance sig)
	;; GET-DISTANCE: a list of distances, one for each argument
	;; and one for the method itself.  The method distance is
	;; either 0 for static methods, or it is the distance between the
	;; class owning the method and the actual class of the object
	;; from which we're starting our search for the method.
	(define (distance desired-type type)
	  (supertype-loop desired-type type 0))
	(let ((modifiers (signature.modifier sig)))
	  (cons (if (memq 'STATIC modifiers)
		    0
		    (distance (car rest-classes)
			      (object.class (object.this object))))
		(map distance
		     (map lookup-class (signature.arg-types sig))
		     arg-types))))

      (define (better? new-dist best-dist)
	;; If any argument is unable to be coerced, then this isn't an
	;; acceptable choice.  If there's no current best, then the
	;; new one is best.  Otherwise, we really have to compare the
	;; new to the current best.
	(cond ((memq #F new-dist) 'NO)
	      ((not best-dist) 'YES)
	      (else (decide new-dist best-dist 'TIE))))

      ;; METHOD-LOOP:
      (if (null? rest)
	  (if best-method
	      (next best-method object best-class)
	      (error "No method found"))
	  (let ((dist (get-distance (car rest-sigs))))
	    (case (better? dist best-dist)
	      ((YES)
	       (method-loop
		(cdr rest) (cdr rest-sigs) (cdr rest-classes)
		(car rest) dist (car rest-classes)))
	      ((NO)
	       (method-loop
		(cdr rest) (cdr rest-sigs) (cdr rest-classes)
		best-method best-dist best-class))
	      (else (error "Ambiguous method choice"))))))
    (method-loop all-methods signatures classes #F #F #F))

  (define (find-all-matching-methods object class name more)
    ;; Starting from the given CLASS, find all methods with the
    ;; desired name that match the count of the arguments that will be
    ;; provided.  Call (MORE methods signatures classes)
    (define nargs (length arg-types))
    (define (class-loop class methods signatures classes)
      (define (method-loop methods-left methods-OK signatures-OK)
        (if (null? methods-left)
            (class-loop (ev-class.superclass class)
                        (append methods-OK methods)
                        (append signatures-OK signatures)
                        (append
                         (map (lambda (x) class) methods-OK)
                         classes))
            (let* ((binding (car methods-left))
                   (method (binding.value binding))
                   (this-name (binding.name binding))
                   (signature (binding.type-name binding)))
              (if (and (eq? name this-name)
                       (= (length (signature.arg-types signature))
                          nargs)
                       (or object
                           (memq 'STATIC
                                 (signature.modifier signature))))
                  (method-loop (cdr methods-left)
                               (cons method methods-OK)
                               (cons signature signatures-OK))
                  (method-loop (cdr methods-left)
                               methods-OK
                               signatures-OK)))))
      ;; Body of CLASS-LOOP:
      (if (or (predefined-class? class) (null? class))
          (more methods signatures classes)
          (method-loop (ev-class.methods class) '() '())))
    (class-loop class '() '() '()))

  (define (find-object-initial-class-and-name more)
    ;; Call (MORE object initial-class name)
    (define (simple-name name)
      ;; A name can be used either from a static method or a dynamic
      ;; method.
      (let ((base-env (environment.base env)))
        (case (frame.tag base-env)
          ((GLOBAL) (error "Can't directly call a method from top level"))
          ((CLASS) (more #F base-env name))
          ((OBJECT)
           ;; Note that the initial class is the actual class of the
           ;; object, not the class to which it may have been cast.
           (more base-env
                 (object.class (object.this base-env))
                 name))
          (else (error "Bad base frame")))))

    (define (dot-name method)
      (define (name-loop obj names)
        ;; Loop over all the names, looking up each in the current
        ;; object's name space.  Notice that the search for the method
        ;; will begin at the true class of the final object, not the
        ;; class to which it may have been cast.
        (if (null? (cdr names))
            (more obj (object.class (object.this obj)) (car names))
            (find-value (car names) (basic-environment obj)
             (lambda (value)
               (name-loop value (cdr names))))))
      (let ((expr (dot.expr method))
            (names (dot.names method)))
        ;; THIS and SUPER are only allowed inside a dynamic method.
        ;; They refer to the object itself or its parent
        ;; (respectively).  This does *not* start by casting to the
        ;; true type of the object, though, since it isn't the method
        ;; lookup yet -- just the starting point for the search.
        (case expr
          ((THIS) (let ((base (environment.base env)))
                    (case (first base)
                      ((GLOBAL) (error "THIS not allowed at top level"))
                      ((CLASS) (error "THIS not allowed in static method"))
                      ((OBJECT) (name-loop base names))
                      (else (error "Bad base environment")))))
          ((SUPER) (let ((base (environment.base env)))
                     (case (first base)
                       ((GLOBAL) (error "SUPER not allowed at top level"))
                       ((CLASS) (error "SUPER not allowed in static method"))
                       ((OBJECT)
                        (let ((super (object.superobject base)))
                          (if super
                              (name-loop super names)
                              (error "No parent object for SUPER"))))
                       (else (error "Bad base environment")))))
          (else (j-eval expr env
                        (lambda (val)
                          (name-loop val names)))))))
        
    ;; Body of FIND-OBJECT-INITIAL-CLASS-AND-NAME:
    (if (java-name? method-name)
        (simple-name method-name)
        (dot-name method-name)))

  ;; METHOD-LOOKUP:
  (find-object-initial-class-and-name
   (lambda (object initial-class name)
     (find-all-matching-methods object initial-class name
       (lambda (methods signatures classes)
         (find-best-method object methods signatures classes))))))

;;; Utility Procedures

(define (j-eval-in-order exps env next)
  ;; Evaluate the EXPS from left to right, and return a list of the
  ;; results.
  (if (null? exps)
      (next '())
      (j-eval (car exps) env
        (lambda (val)
          (j-eval-in-order (cdr exps) env
            (lambda (rest-of-values)
              (next (cons val rest-of-values))))))))

(define (get-type object)
  ;; Given an object at runtime, return the type description.  Notice
  ;; the oddball case of NULL coming in and returning a type
  ;; description of VOID.
  (cond ((pair? object)
         (case (first object)
           ((OBJECT) (object.class object))
           ((CLASS)  *class*?)
           ((INTERFACE) *interface*?)
           (else "Unknown tagged runtime type")))
        ((null? object) 'VOID)
        ((number? object) number?)
        ((boolean? object) boolean?)
        ((char? object) char?)
        ((string? object) string?)
        (else "Unknown untagged runtime type")))

(define (get-self obj)
  ;; Get the "true self" of the object, independent of any casting or
  ;; coercion that may have occurred.
  (if (object? obj)
      (object.this obj)
      obj))

(define (get-class obj)
  ;; Get the actual class of an object at runtime, not the class to
  ;; which it may have been cast or coerced
  (get-type (get-self obj)))

(define (type->default-value-expr type)
  ;; Given a TYPE (not a TYPE-NAME), return a J-I-S expression that
  ;; can be evaluated to return its default value.  This will always
  ;; be some form of literal (self-evaluating) expression.
  (cond ((eq? type number?) 0)
        ((eq? type boolean?) #F)
        ((eq? type char?) (integer->char 0))
        ((eq? type string?) "")
        ((eq? type *object*?) '())
        ((predefined-class? type)
         (error "No default value for this predefined type"))
        (else '())))

(define (get-initializer type-name)
  ;; Given the name of a type, return a procedure that takes a
  ;; variable declaration for a variable of that type and returns the
  ;; correct J-I-S expression to initialize it.  This will either be a
  ;; default value from the Java language definition or the value
  ;; specified in the variable declaration.
  (let ((typedesc (lookup-class type-name)))
    (let ((default-expr (type->default-value-expr typedesc)))
      (lambda (var-decl)
        (var-decl.init-val var-decl default-expr)))))

(define predefined-class? procedure?)

(define (java-class? tag)
  ;; Returns the Scheme type predicate for things that are directly of
  ;; JAVA type specified by TAG.
  (lambda (obj)
    (and (pair? obj)
         (eq? (car obj) tag))))

(define *object*?    (java-class? 'OBJECT))
(define *class*?     (java-class? 'CLASS))
(define *interface*? (java-class? 'INTERFACE))

(define (any predicate list)
  ;; Returns the first entry in LIST that satisfies PREDICATE
  (if (null? list)
      #F
      (let ((result (predicate (car list))))
        (if result
            (car list)
            (any predicate (cdr list))))))

(define (is-static? get-modifiers)
  (lambda (obj)
    (memq 'STATIC (get-modifiers obj))))

(define static-method? (is-static? method.modifiers))
(define static-field? (is-static? field.modifiers))

(define (flatten list-of-lists)
  (apply append list-of-lists))

;;; Global name spaces (global environment, types, labels)

;; Implemented using a global variable whose value is a list of
;; bindings, hence can be treated as a Scheme alist.

(define the-global-environment 'CALL-INITIALIZE-JAVA-ENVIRONMENT)
(define *classes* '())
(define *labels* '())

(define (lookup-global name global-var error-msg)
  ;; Find the value of a name in a global name space
  (let ((entry (assq name global-var)))
    (if entry
        (binding.value entry)
        (error error-msg name))))

(define (lookup-class name)
  (lookup-global name *classes* "No such class"))

(define (lookup-label name)
  (lookup-global name *labels* "No such label"))

(define (exit exp default-label)
  ;; Evaluate the procedure associated with a given label, supplying a
  ;; default label if none is specified to use.  Used to implement
  ;; (BREAK) and (BREAK <label>), etc.
  (let ((name (if (null? (list-tail exp 1))
                  default-label
                  (second exp))))
    ((lookup-label name))))

(define (add-class! name class)
  (let ((entry (assq name *classes*)))
    (if entry
        (begin
          (set-binding.value! entry class)
          'REPLACED)
        (begin
          (set! *classes*
                `(,(make-binding name 'CLASS class)
                  ,@*classes*))
          'ADDED))))

(define (add-label! name label)
  (set! *labels*
    `(,(make-binding name '*LABEL* label)
      ,@*labels*)))

(define (define-global! name type-name value)
  (let ((frame (first-frame the-global-environment)))
    (let ((found (assq name (frame.bindings frame))))
      (if found
          (begin
            (set-binding.value! found value)
            'MODIFIED)
          (begin
            (set! the-global-environment
                  (basic-environment
                   (make-frame
                    'GLOBAL
                    (make-bindings
                     (cons name (frame.names frame))
                     (cons type-name (frame.type-names frame))
                     (cons value (frame.values frame))))))
            'ADDED)))))

;;; Debugging

(define (ev-class.print-name class)
  (if (predefined-class? class)
      (cond ((eq? class number?) 'number)
            ((eq? class string?) 'string)
            ((eq? class boolean?) 'boolean)
            ((eq? class char?) 'char)
            ((eq? class *object*?) 'object)
            (else "Unknown base class"))
      (ev-class.name class)))

(define (show-env env)
  (define (loop n env)
    (if (not env)
        'DONE
        (let ((entry (first-frame env)))
          (display (list "Frame" n (car entry))) (newline)
          (display (frame.names entry)) (newline)
          (case (car entry)
            ((BINDINGS FOR VARIABLES)
             (loop (+ 1 n) (rest-of-frames env)))
            ((CLASS)
             (if (not (null? (cdr env)))
                 (display "Shouldn't be any more"))
             (display (list 'CLASS 'NAME (ev-class.name entry)))
             (newline))
            ((INTERFACE)
             (if (not (null? (cdr env)))
                 (display "Shouldn't be any more"))
             (display (list 'INTERFACE 'NAME (ev-class.name entry)))
             (newline))
            ((OBJECT)
             (if (not (null? (cdr env)))
                 (display "Shouldn't be any more"))
             (display (list 'OBJECT 'CLASS
                            (ev-class.name (object.class entry)))))
            ((GLOBAL)
             (if (not (null? (cdr env)))
                 (display "Shouldn't be any more")))
            (else (error "Bad frame" entry))))))
  (loop 0 env))

(define (show-class class)
  (display (list 'CLASS (ev-class.print-name class)
                 'EXTENDS
                 (ev-class.print-name (ev-class.superclass class))))
  (newline)
  (display (cons 'IMPLEMENTS (map interface.name
                                  (ev-class.implements class))))
  (newline)
  (display `(STATIC FIELDS
                    ,@(map binding.name
                           (ev-class.class-fields class))))
  (newline)
  (display `(METHODS
             ,@(map (lambda (binding)
                      `(,(binding.name binding) :
                        ,@(method.signature (binding.value binding))))
                    (ev-class.methods class))))
  (newline)
  (display `(OBJECT FIELDS
                    ,@(map binding.name
                           (ev-class.object-fields class))))
  (newline)
  (show-env (basic-environment class)))

(define (show-object obj)
  (if (and (pair? obj) (eq? (car obj) 'OBJECT))
      (display (list 'OBJECT 'CLASS
                     (ev-class.print-name (object.class obj))))
      (display "Not a reference object"))
  (newline))

(define (show-interface iface)
  (display `(INTERFACE ,(interface.name iface)
             IMPLEMENTS ,@(map interface.name (interface.implements iface))))
  (newline)
  (show-env (list (interface.frame iface))))

(define (user-print thing)
  (cond ((pair? thing)
         (case (car thing)
           ((OBJECT) (show-object thing))
           ((CLASS) (show-class thing))
           ((INTERFACE) (show-interface thing))
           (else (show-env thing))))
        (else (display thing) (newline))))

(define (run-exprs exprs)
  (define (loop rest)
    (j-eval (car rest) the-global-environment
      (lambda (result)
        (if (null? (cdr rest))
            result
            (loop (cdr rest))))))
  (initialize-java-environment)
  (loop exprs))

(define (test n)
  (run-exprs
   `((CLASS fact
            (METHOD (public static) number fact-fn ((number n))
                    (? (== n 0) 1 (* n (call fact-fn (- n 1))))))
     (global fact (= x (new fact)))
     (call (dot x fact-fn) ,n))))

(define (test2 n)
  (run-exprs
   `((CLASS fact
            (METHOD (public static) number fact-fn ((number n))
              (VARIABLES number ((= result 1))
                (BLOCK
                 (FOR (number (= i 2)) (<= i n) (+= i 1)
                      (*= result i))
                 (RETURN result)))))
     (global fact (= x (new fact)))
     (call (dot x fact-fn) ,n))))

(define (test3)
  (go
   `(CLASS fact
            (METHOD (public static) number fact-fn ((number n))
              (VARIABLES number ((= result 1))
                (BLOCK
                 (FOR (number (= i 2)) (<= i n) (+= i 1)
                      (*= result i))
                 (RETURN result)))))))

;;; Start-up the system

(initialize-java-environment)