;;;; Jeremy Daniel, April 27, 1997 
;;;; made code that needs to be written by students into 
;;;; (error "java-working not loaded")

;;;; Built-in operations

(define (operator.name entry) (first entry))
(define (operator.arity entry) (second entry))
(define (operator.scheme entry) (third entry))

(define (java-plus a b)
  (cond ((and (string? a) (string? b))
         (string-append a b))
        ((and (number? a) (number? b))
         (+ a b))
        (else (error "Bad arguments to +"))))

(define operators
  ;; Name  | # of args | Scheme Procedure
  ;;       |  (arity)  |
  `((-       2           ,-)
    (/       2           ,/)
    (*       2           ,*)
    (==      2           ,=)
    (<       2           ,<)
    (>       2           ,>)
    (<=      2           ,<=)
    (>=      2           ,>=)
    (print   1           ,display)
    (newline 0           ,newline)
    (!=      2           ,(lambda (x y) (not (= x y))))
    (+       2           ,java-plus)
    ;; 3 special cases!
    (AND     #F          #F)
    (OR      #F          #F)
    (?       3           #F)))

;;;; Assignment operations

(define (assign-op.name entry) (first entry))
(define (assign-op.rewrite entry) (second entry))

(define assignments
  ;; Name  | Scheme procedure
  `((=       ,(lambda (old new) new))
    (*=      ,*)
    (/=      ,/)
    (+=      ,java-plus)
    (-=      ,-)))

;;;; Special names for various reasons

(define java-modifiers
  '(PUBLIC PROTECTED PRIVATE STATIC ABSTRACT FINAL))

(define java-reserved-names
  (append '(*BREAK-LABEL* *CONTINUE-LABEL* *RETURN-LABEL*)
          java-modifiers
          (map operator.name operators)
          (map assign-op.name operators)
          '(FALSE NULL TRUE
	    CLASS INTERFACE EXTENDS IMPLEMENTS FIELD METHOD
            STATIC VARIABLES IF WHILE DO BLOCK FOR THIS
            NEW DOT SUPER CALL CAST INSTANCEOF)))

;;;; Utility procedures

(define (all? predicate list)
  ;; Returns #T iff all items in LIST satisfy PREDICATE
  (if (null? list)
      #T
      (and (predicate (car list))
           (all? predicate (cdr list)))))

(define (java-name? obj)
  ;; "Names" are any symbol that isn't used for something special in
  ;; Java
  (and (symbol? obj)
       (not (memq obj java-reserved-names))))

(define (simple?
         form special-form-name min-length max-length)
  ;; Commonly used for simple tests: returns #T iff the FORM is a list
  ;; starting with the SPECIAL-FORM-NAME of at least MIN-LENGTH and no
  ;; longer than MAX-LENGTH.  MAX-LENGTH may be #F to mean that there
  ;; is no upper bound to the length.
  (and (pair? form)
       (eq? (first form) special-form-name)
       (and (>= (length form) min-length)
            (or (not max-length)
                (<= (length form) max-length)))))

(define (class-name? obj)
  ;; This might be extended to actually test that the name is for a
  ;; class, but for now it just tests that it's a valid name.
  (and (java-name? obj)
       #T))

(define (modifiers? l)
  ;; Syntax test for modifier lists
  (and (list? l)
       (all? (lambda (m) (memq m java-modifiers))
             l)))

(define (var-decl? obj)
  ;; <name> or (= <name> <expr>)
  (or (java-name? obj)
      (and (list? obj)
           (= (length obj) 3)
           (eq? (first obj) '=)
           (java-name? (second obj))
           (expr? (third obj)))))

(define (var-decl.name vdecl)
  (if (java-name? vdecl)
      vdecl
      (second vdecl)))

(define (var-decl.init-val vdecl default-value)
  (if (java-name? vdecl)
      default-value
      (third vdecl)))

(define (typed-expr? obj type)
  ;; Later we might want to allow checking of the type of an
  ;; expression, so this is intended to allow us to express the
  ;; required compile-time type of the expression.  For now, we just
  ;; make sure it is an expression!
  (and (expr? obj)
       #T))

(define (make-quick-test name)
  ;; For some complicated structures (like CLASS) it is nice to have a
  ;; very fast initial test that can be followed by a more detailed
  ;; test later.  This just checks that we've go a pair starting with
  ;; NAME.
  (lambda (x)
    (and (pair? x)
         (eq? (car x) name))))

;;;; Syntax Abstractions

(define variable? java-name?)

(define (dot? obj)
  ;; (DOT <expr> <name> ...)
  ;; Note: <expr> can be the special word THIS or SUPER
  (and (simple? obj 'DOT 3 #F)
       (let ((expr (second obj)))
         (or (memq expr '(THIS SUPER))
             (expr? expr)))
       (all? java-name? (list-tail obj 2))))

(define (dot.expr dot-expr) (second dot-expr))
(define (dot.names dot-expr) (list-tail dot-expr 2))

(define (self-evaluating? obj)
  ;; These evaluate to themselves: the Java and Scheme representation
  ;; are the same
  (or (number? obj)
      (boolean? obj)
      (char? obj)
      (string? obj)))

(define (literal? obj)
  ;; NULL is Java for '() in Scheme, TRUE for #T, and FALSE for #F
  (or (self-evaluating? obj)
      (case obj
	((NULL FALSE TRUE) #T)
	(else #F))))

(define (built-in-expr? obj)
  ;; (<operator> <operands> ...)
  (and (pair? obj)
       (let ((record (assq (first obj) operators)))
         (and record
              (let* ((max-arity
                      (if (operator.scheme record)
                          (+ 1 (operator.arity record))
                          #F))
                     (min-arity (or max-arity 0)))
                (and (simple? obj (first obj) min-arity max-arity)
                     (all? expr? (list-tail obj 1))))))))
(define (built-in.operator exp) (first exp))
(define (built-in.operands exp) (cdr exp))

(define (assignment? obj)
  ;; (<assignment operator> <assignable> <expr>)
  (define (left-hand-side? obj)
    ;; The only thing allowed is either a Java name or (DOT ...)
    (or (java-name? obj)
        (dot? obj)))
  (and (pair? obj)
       (let ((record (assq (first obj) assignments)))
         (and record
              (simple? obj (first obj) 3 3)
              (left-hand-side? (second obj))
              (expr? (third obj))))))

(define (assignment.operator assign-expr) (first assign-expr))
(define (assignment.assigned assign-expr) (second assign-expr))
(define (assignment.value assign-expr) (third assign-expr))

(define (new? obj)
  ;; We don't support explicit constructors, so we have a simplified
  ;; syntax: (NEW <class-name>) rather than
  ;;  (NEW <class-name> <expr> ...)
  (and ;; (simple? obj 'NEW 2 #F)
       (simple? obj 'NEW 2 2)
       (class-name? (second obj))
       (all? expr? (list-tail obj 2))))

(define (new.type new-expr) (second new-expr))
; (define (new.expr new-expr) (third new-expr))

(define (call? obj)
  ;; (CALL <expr> ...)
  ;; But the first <expr> must be either (DOT ...) or JAVA-NAME
  (and (simple? obj 'CALL 2 #F)
       (or (dot? (second obj)) (java-name? (second obj)))
       (all? expr? (list-tail obj 2))))

(define (call.operator call-expr) (second call-expr))
(define (call.operands call-expr) (list-tail call-expr 2))

(define (cast? obj)
  ;; (CAST <type> <expr>)
  (and (simple? obj 'CAST 3 3)
       (class-name? (second obj))
       (expr? (third obj))))

(define (cast.type cast-expr) (second cast-expr))
(define (cast.expr cast.expr) (third cast.expr))

(define (instanceof? obj)
  ;; (INSTANCEOF <expr> <type>)
  (and (simple? obj 'INSTANCEOF 3 3)
       (expr? (second obj))
       (class-name? (third obj))))

(define (instanceof.expr instanceof-expr) (second instanceof-expr))
(define (instanceof.type instanceof-expr) (third instanceof-expr))

(define (expr? obj)
  ;; (<operator> . <args>) from list earlier
  ;; (<assignment> <lefthandside> <expr>) from list earlier
  ;; literals
  ;; variables
  ;; (NEW <ClassType> <expr> ...)
  ;; (DOT <primary-expr> <symbol> ...) or (DOT SUPER <symbol> ...)
  ;;                                   or (DOT THIS <symbol>...)
  ;; (CALL <expr> <expr>*)
  ;; (CAST <type> <expr>)
  ;; (INSTANCEOF <expr> <type>)

  (or (literal? obj)
      (java-name? obj)
      (new? obj)
      (dot? obj)
      (call? obj)
      (cast? obj)
      (instanceof? obj)
      (built-in-expr? obj)
      (assignment? obj)))

(define (variables? obj)
  ;; (VARIABLES <type> (<VariableDecl> ...) <statement>)
  (and (simple? obj 'VARIABLES 4 4)
       (class-name? (second obj))
       (all? var-decl? (third obj))
       (statement? (fourth obj))))
(define (variables.type exp) (second exp))
(define (variables.var-decls exp) (third exp))
(define (variables.statement exp) (fourth exp))

(define (global? obj)
  ;; (GLOBAL <type> <VariableDecl> ...)
  (and (simple? obj 'GLOBAL 3 #F)
       (class-name? (second obj))
       (all? var-decl? (list-tail obj 2))))

(define (global.decls exp) (list-tail exp 2))
(define (global.type exp) (second exp))

(define (if? obj)
  ;; (IF <boolean expr> <statement> <statement>)
  (and (simple? obj 'IF 4 4)
       (typed-expr? (second obj) 'BOOLEAN)
       (statement? (third obj))
       (statement? (fourth obj))))

(define (if.predicate exp) (second exp))
(define (if.consequent exp) (third exp))
(define (if.alternative exp) (fourth exp))

(define (while? obj)
  ;; (WHILE <boolean expr> <statement>)
  (and (simple? obj 'WHILE 3 3)
       (typed-expr? (second obj) 'BOOLEAN)
       (statement? (third obj))))

(define (while.predicate exp) (second exp))
(define (while.statement exp) (third exp))

(define (do? obj)
  (error "java-working not loaded")
; comment out above line once you've filled in code
  ;; Moved to JAVA-WORKING
  ;; (DO <statement> <boolean expr>)
  ...)

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

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

(define (block? obj)
  ;; (BLOCK <statement> ...)
  (and (simple? obj 'BLOCK 2 #F)
       (all? statement? (list-tail obj 1))))

(define (label? obj)
  ;; (LABEL <name> <statement>)
  (and (simple? obj 'BLOCK 3 3)
       (java-name? (second obj))
       (statement? (third obj))))

(define (label.name exp) (second exp))
(define (label.statement exp) (third exp))

(define (return? obj)
  ;; (RETURN) or (RETURN <expression>)
  (and (simple? obj 'RETURN 1 2)
       (or (null? (list-tail obj 1))
           (expr? (second obj)))))

(define (break? obj)
  ;; (BREAK) or (BREAK <name>)
  (and (simple? obj 'BREAK 1 2)
       (or (null? (list-tail obj 1))
           (java-name? (second obj)))))

(define (continue? obj)
  ;; (CONTINUE) or (CONTINUE <name>)
  (and (simple? obj 'CONTINUE 1 2)
       (or (null? (list-tail obj 1))
           (java-name? (second obj)))))

(define (for? obj)
  ;; (FOR <statement | typed-var-decls>
  ;;      <boolean expr> <statement> <statement>)
  ;; Java actually allows multiple statements in the init (using ","),
  ;; but that's a mess here, so it's restricted to one statement.  The
  ;; update part isn't allowed to be an arbitrary statement, but we
  ;; allow it here for simplicity.
  (and (simple? obj 'FOR 5 5)
       (let ((init (second obj)))
         (or (statement? init)
             (and (pair? init)
                  (java-name? (car init))
                  (all? var-decl? (list-tail init 1)))))
       (typed-expr? (third obj) 'BOOLEAN)
       (statement? (fourth obj))
       (statement? (fifth obj))))

(define (for.initialize exp) (second exp))
(define (for.predicate exp) (third exp))
(define (for.update exp) (fourth exp))
(define (for.statement exp) (fifth exp))

(define (statement? obj)
  (or (expr? obj)
      (and (pair? obj)
           (case (car obj)
             ((BLOCK) (all? statement? (list-tail obj 1)))
             ((BREAK) (break? obj))
             ((CONTINUE) (continue? obj))
             ((DO) (do? obj))
             ((FOR) (for? obj))
             ((IF) (if? obj))
             ((LABEL) (label? obj))
             ((RETURN) (return? obj))
             ((VARIABLES) (variables? obj))
             ((WHILE) (while? obj))
             (else #F)))))

;;;; CLASSES and INTERFACES
;;;;
;;;; These are very complex and have supporting code for their
;;;; components: METHODs, FIELDs, and STATIC initializers.

;;; FIELDs appear in INTERFACE or CLASS, and are somewhat complex.
;;; They have more than just the standard predicate and selector
;;; procedures.

(define (field? form)
  ;; (FIELD <modifiers> <type> (<VariableDecl>...))
  ;;   where <VariableDecl> is VAR-DECL, earlier
  ;; NOTE: this isn't a simple predicate.  It returns either #F or a
  ;; "canonicalized" version of the input expression.  It is this
  ;; canonicalized version that matches the selectors below.
  (or (and (simple? form 'FIELD 4 4)
           (modifiers? (second form))
           (class-name? (third form))
           (all? var-decl? (fourth form))
           (list 'FIELD `(MODIFIERS ,(second form))
                 (third form) (fourth form)))
      (and (simple? form 'FIELD 3 3)
           (class-name? (second form))
           (all? var-decl? (third form))
           (list 'FIELD '(MODIFIERS ())
                 (second form) (third form)))))

(define (field.modifiers field)
  ;; Remove the MODIFIERS tag
  (second (second field)))
(define field.type third)
(define field.var-decls fourth)

(define quick-field-test? (make-quick-test 'FIELD))

(define (field->var-names field)
  ;; Given a FIELD expression, return all of the names it declares
  (map var-decl.name (field.var-decls field)))

(define (field->type-names field)
  ;; Given a FIELD expression, return a list of type names, one for
  ;; each declared name
  (let ((type-name (field.type field)))
    (map (lambda (x) type-name) (field.var-decls field))))

;;; Methods, which appear only within CLASS or INTERFACE

(define (parameter-decl? form)
  ;; (<type> <name>)
  (and (list? form)
       (= (length form) 2)
       (class-name? (first form))
       (java-name? (second form))))
(define (parameter.type param) (first param))
(define (parameter.name param) (second param))

(define (method-or-header? body-OK?)
  ;; Creates a procedure that accepts a form as input and returns
  ;; either #F or a canonicalized version of that form as output.
  (lambda (form)
    ;; Returns (METHOD (MODIFIERS ...) <type-name or VOID>
    ;;                 <name> (<parameter>...) <statement>)
    ;; or (METHOD-HEADER (MODIFIERS ...) <type-name or VOID>
    ;;                   <name> (<parameter>...))
    ;; or #F
    ;;    where <parameter> is (<type> <name>)
    (let ((min-length (if body-OK? 5 4))
          (max-length (if body-OK? 6 5)))
      (or 
       (and (simple? form 'METHOD max-length max-length)
            (modifiers? (second form))
            (let ((type-name (third form)))
              (or (eq? type-name 'VOID)
                  (class-name? type-name)))
            (java-name? (fourth form))
            (all? parameter-decl? (fifth form))
            (or (and (not body-OK?)
                     `(METHOD-HEADER (MODIFIERS ,(second form))
                                     ,(third form) ; return type
                                     ,(fourth form) ; name
                                     ,(fifth form))) ; parameters
                (and (statement? (sixth form))
                     `(METHOD (MODIFIERS ,(second form))
                              ,(third form) ; return type
                              ,(fourth form) ; name
                              ,(fifth form) ; parameters
                              ,(sixth form))))) ; body
       (and (simple? form 'METHOD min-length min-length)
            (let ((type-name (second form)))
              (or (eq? type-name 'VOID)
                  (class-name? type-name)))
            (java-name? (third form))
            (all? parameter-decl? (fourth form))
            (or (and (not body-OK?)
                     `(METHOD-HEADER (MODIFIERS)
                                     ,(second form) ; return type
                                     ,(third form) ; name
                                     ,(fourth form))) ; parameters
                (and (statement? (fifth form))
                     `(METHOD (MODIFIERS ())
                              ,(second form) ; return type
                              ,(third form) ; name
                              ,(fourth form) ; parameters
                              ,(fifth form)))))))))

;; These selectors work only on the canonicalized output of
;; the procedure produced by METHOD-OR-HEADER?.

(define (method.modifiers exp)
  ;; Remove MODIFIERS tag
  (second (second exp)))
(define method.type third)
(define method.name fourth)
(define method.params fifth)
(define method.body sixth)

(define (method.signature method)
  ;; This can be used wherever a TYPE-NAME is needed
  (let ((arg-types (map parameter.type (method.params method))))
    `(,arg-types -->
      ,(method.modifiers method) ,(method.type method))))

(define (signature.arg-types signature) (first signature))
(define (signature.modifier signature) (third signature))
(define (signature.result-type signature) (fourth signature))

(define method? (method-or-header? #T))
(define method-header? (method-or-header? #F))

(define quick-method-test? (make-quick-test 'METHOD))

;;; STATIC items appear only in CLASSes or INTERFACEs

(define (static? form)
  ;; (STATIC <statement>)
  (and (simple? form 'STATIC 2 2)
       (statement? (second form))))

(define static.statement second)
(define quick-static-test? (make-quick-test 'STATIC))

;;; Support code for handling the body part of CLASS and INTERFACE

(define (class/interface-tail rest keywords body-types finalize)
  ;; Check and canonicalize the body of a CLASS or INTERFACE.

  ;;   REST is the part of the form to be checked.
  ;;   KEYWORDS are the legal keywords (EXTENDS, IMPLEMENTS) that can
  ;;     appear at this point.
  ;;   BODY-TYPES is an a-list mapping tags (STATIC, METHOD, FIELD) to
  ;;     handlers for checking the syntax.
  ;;   FINALIZE is the procedure to call with the canonicalized
  ;;     information: the EXTENDS list, the IMPLEMENTS list, and the
  ;;     entire body.

  ;; Note: The code here "knows" that EXTENDS must precede IMPLEMENTS,
  ;; that each can appear only once, that the default value for the
  ;; extends list is (EXTENDS OBJECT) while the default value for the
  ;; implements list is (IMPLEMENTS), and that the only keywords are
  ;; EXTENDS and IMPLEMENTS.

  (define (extends? form)
    ;; (EXTENDS <class-name>)
    (and (simple? form 'EXTENDS 2 2)
         (class-name? (second form))))

  (define (implements? form)
    ;; (IMPLEMENTS <class-name> ...)
    (and (simple? form 'IMPLEMENTS 2 #F)
         (all? class-name? (list-tail form 1))))

  (define (loop rest keywords extends implements body)
    (if (null? rest)
        (finalize extends implements (reverse body))
        (if (not (pair? (car rest)))
            #F
            (let* ((next (car rest))
                   (form-type (car next)))
              (case form-type
                ((EXTENDS)
                 (and (memq 'EXTENDS keywords)
                      (extends? next)
                      (loop (cdr rest)
                            (if (memq 'IMPLEMENTS keywords)
                                '(IMPLEMENTS)
                                '())
                            next implements '())))
                ((IMPLEMENTS)
                 (and (memq 'IMPLEMENTS keywords)
                      (implements? next)
                      (loop (cdr rest) '() extends next '())))
                (else
                 (let ((handler (assq form-type body-types)))
                   (if handler
                       (let ((result ((cadr handler) next)))
                         (and result
                              (loop (cdr rest) '()
                                    extends implements
                                    (cons result body))))
                       #F))))))))
  (loop rest keywords '(EXTENDS Object) '(IMPLEMENTS) '()))

;;; CLASS syntax

(define quick-class-test? (make-quick-test 'CLASS))

(define (class? form)
  ;; return (CLASS modifiers name superclass
  ;;                         interfaces body-forms)
  ;; or #F

  ;; Note: The modifiers may be omitted from the CLASS, so the syntax
  ;; checking is a bit tricky.

  (define (class-end? modifiers name rest)
    (and (java-name? name)
         (class/interface-tail
          rest                          ; what to check
          '(EXTENDS IMPLEMENTS)         ; legal keywords
          `((FIELD ,field?)             ; body part handlers
            (METHOD ,method?)
            (STATIC ,static?))
          (lambda (extends implements body) ; FINALIZE procedure
            (list 'CLASS `(MODIFIERS ,@modifiers) name
                  extends implements body)))))

  (and (simple? form 'CLASS 2 #F)
       (let ((modifiers (second form)))
         (if (modifiers? modifiers)
             (and (simple? form 'CLASS 3 #F)
                  (class-end? modifiers
                              (third form)
                              (list-tail form 3)))
             (class-end? '()
                         (second form)
                         (list-tail form 2))))))

(define (class.modifiers exp)
  ;; Remove tag MODIFIERS
  (cdr (second exp)))
(define (class.name exp) (third exp))
(define (class.extends exp)
  ;; Remove tag EXTENDS
  (second (fourth exp)))
(define (class.implements exp)
  ;; Remove tag IMPLEMENTS
  (cdr (fifth exp)))
(define (class.body-forms exp) (sixth exp))

;;; INTERFACE

(define quick-interface-test? (make-quick-test 'INTERFACE))

(define (interface? form)
  ;; return (INTERFACE modifiers name superclass body-forms)
  ;; or #F
  (define (end-interface modifiers name rest)
    (and (java-name? name)
         (class/interface-tail
          rest                          ; what to check
          '(EXTENDS)                    ; keywords allowed
          `((FIELD ,field?)             ; body parts
            (METHOD ,method-header?))
          (lambda (extends implements body) ; FINALIZE
            (list 'INTERFACE `(MODIFIERS ,@modifiers)
                  name extends body)))))

  (and (simple? form 'INTERFACE 2 #F)
       (let ((modifiers (second form)))
         (if (modifiers? modifiers)
             (and (simple? form 'INTERFACE 3 #F)
                  (end-interface modifiers (third form)
                                 (list-tail form 3)))
             (and (end-interface '() (second form)
                                 (list-tail form 2)))))))

(define (interface.modifiers exp)
  ;; Remove tag MODIFIERS
  (cdr (second exp)))
(define (interface.name exp) (third exp))
(define (interface.extends exp)
  ;; Remove tag EXTENDS
  (second (fourth exp)))
(define (interface.body-forms exp) (fifth exp))

;;;; Syntax test procedures

(define (syn-test)
  ;; class phw {
  ;;     public static void main() {
  ;;          System.out.println("Hello, world");
  ;;     }
  ;; }

  (class?
   '(CLASS () phw
           (METHOD (public static) void main ()
                   (call (DOT System out println) "Hello, world")))))

(define (syn-test1)
  ;; class phw {
  ;;     public static void main() {
  ;;          System.out.println("Hello, world");
  ;;     }
  ;; }

  (class?
   '(CLASS phw
           (METHOD (public static) void main ()
                   (call (DOT System out println) "Hello, world")))))

(define (syn-test2)
  (class?
   '(CLASS (Private static)
           The-Class-Name
           (extends Something)
           (implements A B C)
      (METHOD () Integer A-Method ((number a) (number b)) 3))))

(define (syn-test3)
  (interface?
   '(interface (Private static)
                The-Class-Name
                (extends Something)
       (METHOD () Integer A-Method ((number a) (number b)) 3))))