;;; This is one possible solution for homework 14.  All changes were
;;; made in eval-exp and eval-stmt.  -erik

;;; java1.ss -- static methods only, no inheritance, interfaces, or types
;;;
;;; C311, Spring 96, Chris Haynes
;;;
;;;
;;; Notation
;;;   *, +: zero (resp, one) or more of the preceding
;;;   ->, |: production and alternation, resp.
;;;   [..]: .. is optional
;;;
;;;
;;; JAVA-SUBSET SYNTAX
;;;
;;; Notation
;;;   "..": terminal ..
;;;   lower-case names: terminals
;;;   names with upper case letters: non-terminals
;;;   ;*: zero or more of the preceding, separated by semi-colon,
;;;   ,*: zero or more of the preceding, separated by comas
;;;
;;; CompilationUnit -> TypeDecl*
;;; TypeDecl -> ClassDecl
;;; ClassDecl -> ClassModifier* class Id { FieldDecl* }
;;; FieldDecl -> static Block
;;;  | VarModifier* Type Id ;
;;;  | public MethodModifier* method id ( parameter,* ) block
;;; ClassModifier -> public
;;; VarModifier -> static | private
;;; MethodModifier -> static | public | private
;;; Parameter -> Type Id
;;; Type -> int | boolean | void | "String"
;;; Block -> { LocalVarDeclOrStmt;* }
;;; LocalVarDeclOrStmt -> LocalVarDecl | Stmt
;;; LocalVarDecl -> Type Id = Exp ;
;;; Stmt -> Exp ;
;;;  | Block
;;;  | if ( Exp ) Stmt else Stmt
;;; Exp -> Literal | Name
;;;  | return [exp]
;;;  | Name = Exp
;;;  | ( Exp BinaryOp Exp )
;;;  | MethodCall
;;;  | ( Exp )
;;; BinaryOp -> + | - | * | ==
;;; MethodCall -> MethodAccess ( Exp,* )
;;; MethodAccess -> Name
;;; Name -> QualifiedName
;;; QualifiedName -> Id | Id . Id | SystemQualifiedName
;;; SystemQualifiedName -> system.out.println
;;; Literal -> Number | Boolean | String
;;;
;;;
;;; SCHEME DATUM SYNTAX
;;;
;;; Notation
;;;   lower-case names: syntactic categories
;;;   upper-case names: terminals
;;;
;;; compilation-unit -> (type-decl*)
;;; type-decl -> class-decl
;;; class-decl -> (CLASS id (class-modifier*) field-decl*)
;;; id -> symbol
;;; field-decl -> (STATIC block)
;;;  | (VAR id (var-modifier*))
;;;  | (METHOD id (method-modifier*) (parameter*) block)
;;; class-modifier -> PUBLIC
;;; var-modifier -> STATIC | PRIVATE
;;; method-modifier -> STATIC | PUBLIC | PRIVATE
;;; parameter -> id
;;; block -> local-var-decl-or-stmt*
;;; local-var-decl-or-stmt -> local-var-decl | stmt
;;; local-var-decl -> (VAR id exp)
;;; stmt -> exp
;;;  | (BEGIN block)
;;;  | (IF exp exp exp)
;;; exp -> literal | name
;;;  | (RETURN [exp])
;;;  | (SET! name exp)
;;;  | method-call
;;; method-call -> (method-access exp*)
;;; method-access -> name
;;; name -> qualified-name
;;; qualified-name -> id | ( id . id ) | primative
;;; primative -> system.out.println | + | * | - | ==
;;; literal -> number | boolean | string
;;;
;;;
;;; SEMANTIC DOMAINS
;;;
;;; denoted-value = variable + method
;;; method = method-closure + primitive
;;; primitive = scheme-procedure
;;; variable = cell(expressed-value + return-continuation)
;;; return-continuation = scheme-continuation
;;; expressed-value = integer + boolean + string + method


;;; Chez extensions
;;;
;;; define-structure, error, case-lambda, record-case, printf

(case-sensitive #t)


;;; Handy tools

(define filter
  (lambda (pred lst)
    (cond
      ((null? lst) '())
      ((pred (car lst)) (cons (car lst) (filter pred (cdr lst))))
      (else (filter pred (cdr lst))))))  

(define compose
  (lambda (f g)
    (lambda (x)
      (f (g x)))))


;;; Syntax predicates

(define static-initializer?
  (lambda (x)
    (and (pair? x)
      (eq? 'static (car x)))))

(define name?
  (lambda (exp)
    (or (id? exp)
      (and (pair? exp)
	(id? (car exp))
	(id? (cdr exp))))))

(define method-call?
  (lambda (exp)
    (and (pair? exp) (name? (car exp)))))

(define id? symbol?)
  
(define literal?
  (lambda (exp)
    (or (number? exp) (boolean? exp) (string? exp))))


;;; Structures

(define-structure (class id modifiers loaded? loading? env))

(define-structure (method id modifiers parameters block class))

(define-structure (var id modifiers value class))


;;; Modifier predicates

(define is-method?
  (lambda (method modifier)
    (memq modifier (method-modifiers method))))

(define is-var?
  (lambda (var modifier)
    (memq modifier (var-modifiers var))))


;;; Environments

(define alist->env
  (lambda (alist)
    (case-lambda ; Chez Scheme feature
      ((id succeed fail) ; formals when env invoked with 3 args
       (let ((y (assq id alist)))
	 (if (pair? y)
	   (succeed (cdr y))
	   (fail))))
      (() ; return alist when env invoked with no args
       alist)))) 

(define env->alist
  (lambda (env)
    (env)))

(define range
  (lambda (env)
    (map cdr (env->alist env))))

(define compose-env
  (lambda (env1 env2)
    (case-lambda
      ((id succeed fail)
       (env2 id succeed (lambda () (env1 id succeed fail))))
      (() (append (env2) (env1))))))

(define extend-env
  (lambda (ids vals env)
    (compose-env env
      (alist->env (map cons ids
		    (map (lambda (id val) (make-var id '() val 'ignored))
		      ids
		      vals))))))

(define lookup
  (lambda (id env)
    (env id
      (lambda (x)
	(cond
	  ((and (class? x) (not (class-loaded? x)))
	   (if (class-loading? x)
	     (error 'lookup "Class initialization cycle: ~s" x)
	     (begin
	       (set-class-loading?! x #t)
	       (apply-method (lookup '<clinit> (class-env x)) '())
	       (set-class-loaded?! x #t)
	       x)))
	  ((method? x)
	   (if (and (is-method? x 'private)
		 (not (eq? (current-class env) (method-class x))))
	     (error 'lookup "method ~s is private" id)
	     x))
	  ((var? x)
	   (if (and (is-var? x 'private)
		 (not (eq? (current-class env) (var-class x))))
	     (error 'lookup "variable ~s is private" id)
	     x))	   
	  (else x)))
      (lambda () (error 'lookup "Unbound id: ~s" id)))))

(define current-class
  (lambda (env)
    (env '<class>
      (lambda (x) x)
      (lambda () (error 'current-class "no current class in ~s" env)))))
	
(define name-lookup
  (lambda (name env)
    (if (id? name)
      (lookup name env)
      (let ((x (lookup (car name) env)))
	(if (class? x)
	  (lookup (cdr name) (class-env x))
	  (error 'name-lookup "Bad name: ~s" name))))))

(define denoted->expressed
  (lambda (denval)
    (if (var? denval)
      (var-value denval)
      denval)))

(define init-env
  (alist->env
    (list
      (cons '+ +)
      (cons '- -)
      (cons '* *)
      (cons '== equal?)
      (cons '< <)
      (cons 'system.out.println (lambda (x) (display x) (newline))))))


;;; Setup and go

(define run
  (lambda (compilation-unit)
    (let* ((cu-local-env 'ignored)
	   (delayed-cu-local-env (lambda args (apply cu-local-env args)))
	   (cu-env (compose-env init-env delayed-cu-local-env)))
      (set! cu-local-env
	(alist->env (map (make-type-decl-proc cu-env) compilation-unit)))
      (let ((publics (filter
		       (lambda (x)
			 (and (class? x)
			   (memq 'public (class-modifiers x))))
		       (range cu-local-env))))
	(if (= 1 (length publics))
	  (let* ((name (cons (class-id (car publics)) 'main))
		 (main-method (name-lookup name cu-local-env)))
	    (if (not (is-method? main-method 'public))
	      (error 'run "main method is not public"))
	    (apply-method main-method '(<void>)))
	  (error 'run "~s public methods." (length publics)))))))

(define make-type-decl-proc
  (lambda (cu-env)
    (lambda (type-decl)
      (record-case type-decl
	(class (id modifiers . field-decls)
	  (let ((class (make-class id modifiers #f #f 'ignored-env)))
	    (set-class-env! class
	      (compose-env cu-env
		(make-class-local-env field-decls class)))
	    (cons id class)))
	(else (error 'run "Bad type-decl: ~s" type-decl))))))

(define make-class-local-env
  (lambda (field-decls class)
    (let* ((initializers (filter static-initializer? field-decls))
	   (init-block (apply append (map cdr initializers)))
	   (class-init-method
	     (make-method '<clinit> '(static) '() init-block class)))
      (alist->env
	(cons (cons '<class> class)
	  (cons (cons '<clinit> class-init-method)
	    (map (make-field-value-proc class)
	      (filter (compose not static-initializer?)
		field-decls))))))))

(define make-field-value-proc
  (lambda (class)
    (lambda (field-decl)
      (record-case field-decl
	(method (id modifiers parameters . block)
	  (if (not (memq 'static modifiers))
	    (error 'make-field-value "method not static: ~s" id)
	    (cons id (make-method id modifiers parameters block class))))
	(var (id modifiers)
	  (if (not (memq 'static modifiers))
	    (error 'make-field-value "var not static: ~s" id)
	    (cons id (make-var id modifiers '<void> class))))
	(else (error 'make-field-value "Bad field: ~s" field-decl))))))


;;; Evaluation

(define apply-method
  (lambda (method args)
    (cond
      ((procedure? method) (apply method args))
      ((memq 'static (method-modifiers method))
       (eval-block/return (method-block method)
	 (extend-env (method-parameters method) args
	   (class-env (method-class method)))))
      (else (error 'apply-method "Method not static: ~s" method)))))

(define eval-block/return
  (lambda (block env)
    (call-with-current-continuation
      (lambda (return)
	(eval-block block (extend-env '(<return>) (list return) env))))))

(define eval-block
  (lambda (block env)
    (if (pair? block)
      (record-case (car block)
	(var (id exp)
	  (eval-block (cdr block)
	    (extend-env (list id)
	      (list (eval-exp exp env))
	      env)))
	(else
	  (eval-stmt (car block) env)
	  (eval-block (cdr block) env))))))

;; these solutions for while, do and for look much more complex than
;; they actually are.

(define eval-stmt
  (lambda (stmt env)
    (if (pair? stmt)
	(record-case stmt
	  (block blk (eval-block blk env))
	  (break ()
	    (let ((<break> (var-value (lookup '<break> env))))
	      (<break> #f)))
	  (continue ()
	    (let ((<continue> (var-value (lookup '<continue> env))))
	      (<continue> #f)))
	  (for (inits loop-stmt)
	    (let ([init-stmt (car inits)]
		  [test-exp (cadr inits)]
		  [inc-stmt (caddr inits)])
	      (call/cc
		(lambda (k)
		  (let ([env (extend-env (list '<break>) (list k) env)])
		    (let ([env (record-case init-stmt
				 (var (id exp)
				   (extend-env (list id)
				     (list (eval-exp exp env))
				     env))
				 (else
				   (eval-stmt init-stmt env)
				   env))])
		      (letrec ([loop
				 (lambda ()
				   (if (eval-exp test-exp env)
				       (begin 
					 (call/cc
					   (lambda (k)
					     (let ([env (extend-env
							  (list '<continue>)
							  (list k)
							  env)])
					       (eval-stmt loop-stmt env))))
					 (eval-stmt inc-stmt env)
					 (loop))))])
			(loop))))))))
	  (while (test-exp loop-stmt)
	    (call/cc
	      (lambda (k)
		(let ([env (extend-env (list '<break>) (list k) env)])
		  (letrec ([loop
			     (lambda ()
			       (if (eval-exp test-exp env)
				   (begin
				     (call/cc
				       (lambda (k)
					 (let ([env (extend-env
						      (list '<continue>)
						      (list k)
						      env)])
					   (eval-stmt loop-stmt env))))
				     (loop))))])
		    (loop))))))
	  (do (loop-stmt test-exp)
	    (call/cc
	      (lambda (k)
		(let ([env (extend-env (list '<break>) (list k) env)])
		  (let ([dofun (lambda ()
				 (call/cc
				   (lambda (k)
				     (let ([env (extend-env (list '<continue>)
						  (list k)
						  env)])
				       (eval-stmt loop-stmt env)))))])
		    (dofun)
		    (letrec ([loop (lambda ()
				     (if (eval-exp test-exp env)
					 (begin
					   (dofun)
					   (loop))))])
		      (loop)))))))
	  (if (test-exp then-stmt else-stmt)
	      (if (eval-exp test-exp env)
		  (eval-stmt then-stmt env)
		  (eval-stmt else-stmt env)))
	  (else (eval-exp stmt env)))
	(eval-exp stmt env))))

(define eval-exp
  (lambda (exp env)
    (cond
      ((literal? exp) exp)
      ((name? exp) (denoted->expressed (name-lookup exp env)))
      ((pair? exp)
       (record-case exp
	 (return exps
	   (let ((<return> (var-value (lookup '<return> env))))
	     (if (null? exps)
	       (<return> '<void>)
	       (<return> (eval-exp (car exps) env)))))
	 (set! (name exp)
	   (set-var-value! (name-lookup name env) (eval-exp exp env)))
	 (? (test-exp then-exp else-exp)
	   (if (eval-exp test-exp env)
	       (eval-exp then-exp env)
	       (eval-exp else-exp env)))
	 (else
	   (if (method-call? exp)
	     (let ((method (name-lookup (car exp) env)))
	       (apply-method method (eval-rands (cdr exp) env)))
	     (error 'eval-exp "Bad expression: ~s" exp)))))
      (else (error 'eval-exp "Bad expression: ~s" exp)))))

(define eval-rands
  (lambda (rands env)
    (if (null? rands)
      '()
      (let ((arg (eval-exp (car rands) env)))
	(cons arg (eval-rands (cdr rands) env))))))


;;; Testing

(define test1
  ;; public class HelloWorld {
  ;;   public static void main(String args[]) {
  ;;     System.out.println("Hello World");
  ;;   }
  ;; }
  '((class HelloWorld (public)
      (method main (public static) (args)
	(system.out.println "Hello World!")))))

(define test2
  ;; public class Test {
  ;;   public static void main(String args[]) {
  ;;     System.out.println(C.m(4) - C.v);
  ;;   }
  ;; }
  ;; class C { 
  ;;   static int v;
  ;;   static private int w;
  ;;   static {
  ;;     v = 2;
  ;;     w = 4;
  ;;   }
  ;;   static int m(int x) {
  ;;     if ( 3 == w )
  ;;       return 3;
  ;;     else {
  ;;       x = ( x + 2 );
  ;;       return (v * x);
  ;;     }
  ;;   }
  ;; }
  '((class HelloWorld (public)
      (method main (public static) (args)
	(system.out.println (- ((C . m) 4)
			      (C . v)))))
    (class C ()
      (var v (static))
      (var w (static private))
      (static
	(set! v 2)
	(set! w 4))
      (method m (static) (x)
	(if (== 3 w)
	  (return 3)	  
	  (block
	    (set! x (+ x 2))
	    (return (* v x))))))))