;;; java1.ss -- static methods only,
;;; and no packages, inheritance, or interfaces, among other things


;;; C311, Fall 96, Chris Haynes


;;; JAVA-SUBSET SYNTAX
;;;
;;; Notation
;;;   *, +: zero (resp, one) or more of the preceding
;;;   ->, |: production and alternation, resp.
;;;   [..]: optional
;;;   "..": 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
;;;
;;; Program -> CompilationUnit
;;;
;;; CompilationUnit -> TypeDeclaration*
;;;
;;; TypeDeclaration -> ClassDeclaration
;;;
;;; ClassDeclaration -> ClassModifiers class Identifier ClassBody
;;;
;;; ClassBody -> { ClassBodyDeclaration* }
;;;
;;; ClassBodyDeclaration -> FieldVariableDeclaration
;;;  | StaticInitializer
;;;  | MethodDeclaration
;;;
;;; MethodDeclaration ->
;;;    MethodModifiers TypeSpecifier MethodDeclarator MethodBody
;;;
;;; MethodModifiers -> MethodModifier*
;;;
;;; MethodDeclarator -> DeclaratorName ( Parameter,* )
;;;
;;; MethodBody -> Block
;;; 
;;; StaticInitializer -> static Block
;;;
;;; FieldVariableDeclaration ->
;;;    VariableModifiers TypeSpecifier VariableDeclarator ;
;;;
;;; VariableModifiers -> static
;;;
;;; TypeSpecifier -> TypeName | TypeSpecifier []
;;;
;;; TypeName -> PrimitiveType | QualifiedName
;;;
;;; PrimitiveType -> boolean | int | void
;;;
;;; QualifiedName -> Identifier | QualifiedName . Identifier
;;;
;;; VariableDeclarator -> DeclaratorName
;;;
;;; DeclaratorName -> Identifier
;;;
;;; ClassModifiers -> [ public ]
;;;
;;; VariableModifier -> static
;;;
;;; MethodModifier -> static | public
;;;
;;; Parameter -> TypeSpecifier DeclaratorName
;;;
;;; Block -> { LocalVariableDeclarationOrStatement;* }
;;;
;;; LocalVariableDeclarationOrStatement -> LocalVariableDeclarationStatement
;;;  | Statement
;;;
;;; LocalVariableDeclarationStatement -> TypeSpecifier VariableDeclarator+ ;
;;;
;;; Statement -> Expression ;
;;;  | Block
;;;  | SelectionStatement
;;;  | JumpStatement
;;;
;;; JumpStatement -> return [ expression ]
;;;
;;; SelectionStatement -> if ( Expression ) Statement [ else Statement ]
;;;
;;; Expression -> AssignmentExpression
;;;
;;; AssignmentExpression -> ConditionalExpression
;;;  | LeftHandSide AssignmentOperator AssignmentExpression
;;;
;;; LeftHandSide -> PrimaryExpression
;;;
;;; PrimaryExpression -> Identifier | NotJustName
;;;
;;; NotJustName -> ComplexPrimary
;;;
;;; ComplexPrimary -> ( Expression )
;;;  | ComplexPrimaryNoParenthesis
;;;
;;; ComplexPrimaryNoParenthesis -> Literal | MethodCall | FieldAccess
;;;
;;; FieldAccess -> NotJustName . Identifier
;;;  | ReallyPostfixExpression . Identifier
;;;
;;; ReallyPostfixExpression -> QualifiedName
;;;
;;; AssignmentOperator -> =
;;;
;;; ConditionalExpression -> EqualityExpression
;;; 
;;; EqualityExpression -> RelationalExpression
;;;  | EqualityExpresson == RelationalExpression
;;;
;;; RelationalExpression -> AdditiveExpression
;;;
;;; AdditiveExpression -> MultiplicativeExpression
;;;  | AdditiveExpression + MultiplicativeExpression
;;;  | AdditiveExpression - MultiplicativeExpression
;;;
;;; MultiplicativeExpression -> CastExpression
;;;  | MultiplicativeExpression * CastExpression
;;;
;;; CastExpression -> PrimaryExpression
;;;
;;; MethodCall -> MethodAccess ( Expression,* )
;;;
;;; MethodAccess -> QualifiedName
;;;
;;; Literal -> Integer | Boolean | String | null
;;;
;;; Boolean -> true | false
;;;
;;; Identifier is a Scheme symbol, but not a Java keyword or literal.
;;;
;;; Integer and String are as in Scheme.
;;;
;;; Assume the following is declared in the compilation unit:
;;;   class Out {
;;;     static void intPrintln(int i) { System.out.println(i); }
;;;     static void stringPrintln(String s) { System.out.println(s); }
;;;   }


;;; SCHEME DATUM SYNTAX
;;;
;;; Differences from Java syntax:
;;;   begin and let are not Java keywords
;;;   integer syntax is Scheme's

(load "/u/chaynes/w/grammar.ss")

(case-sensitive #t)

(define binops '(+ - * ==))

(define binop? (lambda (x) (memq x binops)))

(define literal?
  (lambda (x)
    (or (integer? x) (string? x) (eq? x 'null) (java-boolean? x))))

(define java-boolean? (lambda (x) (or (eq? x 'true) (eq? x 'false))))

(define program?

  (grammar program

    (program compilation-unit)

    (compilation-unit (lst (star type-declaration)))

    (type-declaration
      (report-if-bad 'type-declaration
	class-declaration))

    (class-declaration
      (lst identifier class-modifiers (lst 'class class-body)))

    (identifier
      (predicate
	(lambda (x)
	  (and (symbol? x)
	    (let ((chars (string->list (symbol->string x)))
		  (java-letter? (lambda (char)
				  (or (char-alphabetic? char)
				    (char=? char #\_)
				    (char=? char #\$)))))
	      (and (java-letter? (car chars))
		(andmap (lambda (char)
			  (or (java-letter? char) (char-numeric? char)))
		  chars)))
	    (not (memq x '(public static int boolean void class method if
			    begin let
			    true false null return + - * = ==))))))) 

    (class-modifiers (lst (opt 'public)))
    
    (class-body (star class-body-declaration))

    (class-body-declaration
      (report-if-bad 'class-body-declaration
	(alt static-initializer method-declaration field-variable-declaration)))

    (static-initializer (lst 'static block))

    (method-declaration (lst identifier method-modifiers method-type
			  parameters method-body))

    (method-modifiers (lst (star (alt 'public 'static))))

    (method-type (lst 'method parameter-types return-type))

    (parameter-types (lst (star type-specifier)))

    (type-specifier (alt type-name array-specifier))

    (array-specifier (lst 'array type-specifier))

    (type-name (alt primitive-type qualified-name))

    (primitive-type (alt 'int 'boolean 'void))

    (qualified-name (alt identifier (dot qualified-name identifier)))

    (return-type type-specifier)

    (parameters (lst (star identifier)))

    (method-body block)

    (field-variable-declaration
      (lst identifier variable-modifiers type-specifier))

    (variable-modifiers (lst 'static))

    (block (lst 'begin (star (alt local-variable-declaration-statement
			       statement))))

    (local-variable-declaration-statement
      (lst 'let identifier type-specifier expression))

    (statement
      (report-if-bad 'statement
	(alt select-statement jump-statement block expression)))

    (select-statement (lst 'if expression statement (alt null statement)))

    (null (cfa (lambda (input) (and (null? input) '()))))
    
    (jump-statement (lst 'return (alt null expression)))

    (expression
      (report-if-bad 'expression
	(alt assignment-expression
	  binary-expression
	  literal
	  method-call
	  primary-expression)))

    (assignment-expression (lst '= left-hand-side expression))

    (left-hand-side primary-expression)

    (primary-expression (alt identifier field-access))
    
    (field-access (dot expression identifier))

    (binary-expression (lst binary-operation expression expression))

    (binary-operation (predicate binop?))
    
    (method-call (lst 'call qualified-name (star expression)))

    (literal (predicate literal?))
    
    ))


;;; Abbreviations
;;;
;;;  binop  binary operation
;;;  char   character
;;;  cu     compilation unit
;;;  cvar   class variable
;;;  decl   declaration
;;;  env    environment
;;;  exp    expression
;;;  id     identifier
;;;  init   initial or initialize
;;;  lhs    left-hand side
;;;  lst    list
;;;  mod    modifier
;;;  opt    optional
;;;  rand   operand
;;;  rhs    right-hand-side
;;;  stmt   statement
;;;  str    string
;;;  sym    symbol
;;;  tenv   type environment
;;;  val    value
;;;  var    variable
;;;
;;; suffix s means "list of"


;;; multiple values syntactic extension:
;;;
;;; (mvlet () e ...) ==> (begin e ...)
;;;
;;; (mvlet (((i ...) v) d ...) e ...) ==>
;;;   (call-with-value
;;;     (lambda () v)
;;;     (lambda (i ...)
;;;       (mvlet (d ...) e ...)))
;;;
;;; (values e ...) returns as multiple values the values of e ...
;;;
;;; Thus (mvlet (((a b c) (values 1 2 3)))
;;;        (list c b a))
;;; returns (3 2 1).

(define-syntax mvlet
  (lambda (x)
    (syntax-case x ()
      ((_ () e ...) (syntax (begin e ...)))
      ((_ (((i ...) v) d ...) e ...)
       (syntax (call-with-values
		 (lambda () v)
		 (lambda (i ...)
		   (mvlet (d ...) e ...))))))))
      

;;; general purpose procedures

(define is-a (lambda (sym) (lambda (x) (and (pair? x) (eq? (car x) sym)))))

(define check-is-a
  (lambda (sym x)
    (unless ((is-a sym) x)
      (error 'check-is-a "is not a ~s: ~s" sym x))))

(define mod-is (lambda (mod) (lambda (mods) (memq mod mods))))

(define separate
  (lambda (lst predicate k2)
    (let loop ((lst lst) (yes '()) (no '()))
      (cond
	((null? lst) (k2 yes no))
	((predicate (car lst)) (loop (cdr lst) (cons (car lst) yes) no))
	(else (loop (cdr lst) yes (cons (car lst) no)))))))

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

(define decl-id car)
(define decl-mods cadr)

(define type-decl-class caddr)

(define class-decl-type caddr)

(define method-parameter-types cadr)
(define method-return-type caddr)

(define method-decl-parameters cadddr)
(define method-decl-body (compose car cddddr))

(define id? symbol?)

(define dot? (lambda (x) (and (pair? x) (id? (cdr x)))))

(define primary-exp? (lambda (x) (or (id? x) (dot? x))))

(define has-mod (lambda (sym) (lambda (mods) (memq sym mods))))

(define stmt-keywords '(begin if return))

(define stmt-is-exp?
  (lambda (x) (and (pair? x) (not (memq (car x) stmt-keywords)))))


;;; environments

(define the-empty-env '())

(define extend-env
  (lambda (sym-list val-list env)
    (append (map cons sym-list val-list) env)))

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

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

(define append-env append)

(define get-val cdr)

(define set-val! set-cdr!)

(define apply-env
  (lambda (env sym)
    (let ((x (assq sym env)))
      (if x x
	(parameterize ((print-level 2))
	  (error 'apply-env "~s not bound in ~s" sym env))))))


;;; type environment values

(define make-tenv-val cons)

(define tenv-val-mods car)

(define tenv-val-type cdr)


;;; type environments

(define tenv-lookup
  (lambda (exp tenv)
    (if (id? exp)
      (let ((val (get-val (apply-env tenv exp))))
	(values (tenv-val-mods val)
	  (tenv-val-type val)
	  exp))
      (mvlet (((type new-exp) (check-exp (car exp) tenv)))
	(check-is-a 'class type)
	(let ((val (get-val (apply-env (class-tenv type) (cdr exp)))))
	  (values (tenv-val-mods val)
	    (tenv-val-type val)
	    (cons new-exp (cdr exp))))))))

(define get-type
  (lambda (exp tenv)
    (mvlet (((mods type new-exp) (tenv-lookup tenv exp)))
      type)))
    
(define get-mods
  (lambda (exp tenv)
    (mvlet (((mods type new-exp) (tenv-lookup tenv exp)))
      mods)))


;;; evaluation environments

(define lookup (lambda (sym env) (get-val (apply-env env sym))))

(define assign (lambda (sym val env) (set-val! (apply-env env sym) val)))


;;; class types

(define make-class-type (lambda (tenv) (cons 'class tenv)))

(define class-tenv cdr)


;;; type checker

(define check-cu
  (lambda (cu)
    (separate cu (compose (has-mod 'public) decl-mods)
      (lambda (public others)
	(unless (= 1 (length public))
	  (error 'check-cu
	    "The program compilation unit must have exactly 1 public class"))
	(let ((cu-tenv (make-cu-tenv cu)))
	  (map (lambda (decl) (check-type-decl decl cu-tenv))
	    cu))))))

(define make-cu-tenv
  (lambda (cu)
    (append-env
      (alist->env
	(map (lambda (decl)
	       (cons (decl-id decl)
		 (make-tenv-val (decl-mods decl)
		   (class-type (type-decl-class decl)))))
	  cu))
      init-tenv)))

(define class-type
  (lambda (class)
    (make-class-type
      (alist->env
	(map (lambda (decl)
	       (cons (decl-id decl)
		 (make-tenv-val (decl-mods decl)
		   (class-decl-type decl))))
	  (filter (compose not (is-a 'static))
	    (class-tenv class)))))))

(define check-type-decl
  (lambda (decl cu-tenv)
    (list (decl-id decl)
      (decl-mods decl)
      (check-class (type-decl-class decl) cu-tenv))))

(define check-class
  (lambda (class cu-tenv)
    (let ((class-tenv (append-env
			(alist->env
			  (filter (lambda (binding)
				    ((mod-is 'static)
				     (tenv-val-mods (cdr binding))))
			    (env->alist (tenv-val-type (class-type class)))))
			cu-tenv)))
      (cons 'class
	(separate (cdr class) (is-a 'static)
	  (lambda (initializers decls)
	    (cons (check-block
		    (cons 'begin (apply append (map cdadr initializers)))
		    (extend-env '(<return>)
		      '((() . not-a-type))
		      class-tenv))
	      (map (check-class-body-decl class-tenv) decls))))))))

(define check-class-body-decl
  (lambda (tenv)
     (lambda (decl)
       (if ((is-a 'method) (class-decl-type decl))
	 (let ((parameters (method-decl-parameters decl))
	       (type (class-decl-type decl)))
	   (list (decl-id decl) (decl-mods decl) type parameters
	     (check-block
	       (method-decl-body decl)
	       (extend-env
		 (cons '<return> (method-decl-parameters decl))
		 (map (lambda (type) (make-tenv-val '() type))
		   (cons (method-return-type type)
		     (method-parameter-types type)))
		 tenv))))
	 decl))))

(define match-types
  (lambda (type1 type2)
    (unless (equal? type1 type2) (error 'match-types "~s != ~s" type1 type2))))

(define check-block
  (lambda (block tenv)
    (cons 'begin
      (map (lambda (stmt) (check-stmt stmt tenv))
	(cdr block)))))

(define check-stmt
  (lambda (stmt tenv)
    (if (stmt-is-exp? stmt)
      (mvlet (((type exp) (check-exp stmt tenv)))
	exp)
      (record-case stmt
	(return opt-exp
	  (if (null? opt-exp)
	    (begin (match-types (get-type tenv '<return>) 'void)
	      stmt)
	    (mvlet (((type exp) (check-exp (car opt-exp) tenv)))
	      (match-types type (get-type tenv '<return>))
	      (list 'return exp))))
	(if (test-exp then-stmt . opt-else-stmt)
	  (mvlet (((test-type test-exp) (check-exp test-exp tenv)))
	    (match-types test-type 'boolean)
	    (append (list 'if test-exp (check-stmt then-stmt tenv))
	      (if (null? opt-else-stmt)
		'(begin)
		(list (check-stmt (car opt-else-stmt) tenv))))))
	(begin stmts (check-block stmt tenv))))))

(define check-exp
  (lambda (exp tenv)
    (cond
      ((literal? exp)
       (values (cond
		 ((integer? exp) 'int)
		 ((string? exp) 'String)
		 ((eq? exp 'null) 'Object)
		 (else 'boolean))
	 exp))
      ((primary-exp? exp) (values (get-type tenv exp) exp))
      ((binop? (car exp))
       (mvlet (((type1 new-exp1) (check-exp (cadr exp) tenv))
	       ((type2 new-exp2) (check-exp (caddr exp) tenv)))
	 (let ((binop-type (get-type binop-tenv (car exp))))
	   (match-types type1 (caadr binop-type))
	   (match-types type2 (cadadr binop-type))
	   (values (caddr binop-type)
	     (list (car exp) new-exp1 new-exp2)))))
      (else
	(record-case exp
	  (= (lhs rhs)
	    (mvlet (((lhs-mods lhs-type new-lhs) (tenv-lookup lhs tenv))
		    ((rhs-type new-rhs) (check-exp rhs tenv)))
	      (match-types lhs-type rhs-type)
	      (values lhs-type (list '= new-lhs new-rhs))))
	  (call (qualified-name . exps)
	    (mvlet (((rand-types new-rands) (check-exps exps tenv))
		    ((mods type new-exp) (tenv-lookup qualified-name tenv)))
	      (check-is-a 'method type)
	      (map match-types rand-types (method-parameter-types type))
	      (values (method-return-type type)
		(cons new-exp new-rands)))))))))

(define check-exps
  (lambda (exps tenv)
    (let loop ((exps exps) (types '()) (new-exps '()))
      (if (null? exps)
	(values types new-exps)
	(mvlet (((type new-exp) (check-exp (car exps) tenv)))
	  (loop (cdr exps) (cons type types) (cons new-exp new-exps)))))))


;;; top-level type environments

(define binop-tenv (extend-env
		     binops
		     '((() . (primop (int int) int))
		       (() . (primop (int int) int))
		       (() . (primop (int int) int))
		       (() . (primop (int int) boolean)))
		     the-empty-env))

(define String-class-type ; no String methods yet
  (make-class-type (alist->env '())))

(define Object-class-type ; no Object methods yet
  (make-class-type (alist->env '())))

(define Out-class-type
  (make-class-type
    (alist->env
      '((intPrintln (public) . (method (int) void))
	(stringPrintln (public) . (method (String) void))))))

(define init-tenv (extend-env
		    '(Out String Object)
		    (list
		      (make-tenv-val '(public) Out-class-type)
		      (make-tenv-val '(public) String-class-type)
		      (make-tenv-val '(public) Object-class-type))
		    the-empty-env))


;;; classes

(define-structure (class cvar-names cvar-values))

(define out-class
  (make-class
    '(intPrintln stringPrintln)
    '???))


;;; top-level value environments

(define binop-env (extend-env binops (list + - * =) the-empty-env))

(define init-env (extend-env '(Out) (list out-class) the-empty-env))

(define run (lambda (x) (if (program? x) (eval-cu (check-cu x)))))

(define eval-cu (lambda (x) x)) ; stub

;;; TESTING


;; This class is assumed in all programs.
;; 
;; class Out {
;;   static void stringPrintln(String s) {
;;     System.out.println(s);
;;   }
;;   static void intPrintln(int i) {
;;     System.out.println(i);
;;   }
;; }


;; public class HelloWorld {
;;   public static void main(String[] args) {
;;     Out.stringPrintln("Hello World!");
;;   }
;; }

(define test1
  '((HelloWorld (public)
      (class (main (public static) (method ((array String)) void) (args)
	       (begin (call (Out . stringPrintln) "Hello World!")))))))


;; public class Test {
;;   public static void main(String[] args) {
;;     Out.intPrintln(i);
;;     Out.stringPrintln(C.cvar);
;;     C.meth();
;;     if ( i == 3 ) i = 4;
;;     Out.intPrintln(meth(3));
;;     Out.intPrintln(meth(4));
;;   }
;;   static boolean b;
;;   static { b = true; }
;;   static int i;
;;   static String s;
;;   static { i = 3; s = "string"; }
;;   static int meth(int i) {
;;     if ( b ) return i+1;
;;     else return i-1;
;;   }
;; }
;; class C {
;;   static String cvar;
;;   static { cvar = "cvar value"; }
;;   static Object meth() {
;;     return null;
;;   }
;; }

(define test2
  '((Test (public)
      (class
	(main (public static) (method ((array String)) void) (args)
	  (begin
	    (call (Out . intPrintln) i)
	    (call (Out . stringPrintln) (C . cvar))
	    (call (C . meth))
	    (if (== i 3) (= i 4))
	    (call (Out . intPrintln) (call meth 3))
	    (call (Out . intPrintln) (call meth 4))))
	(b (static) boolean)
	(static (begin (= b true)))
	(i (static) int)
	(s (static) String)
	(static (begin (= i 3) (= s "string")))
	(meth (static) (method (int) int) (i)
	  (begin
	    (if b
	      (return (+ i 1))
	      (return (- i 1)))))))
    (C ()
      (class
	(cvar (static) String)
	(static (begin (= cvar "cvar value")))
	(meth (static) (method () Object) ()
	  (begin (return null)))))))