;; --- MiniJava translator ---

(defun translate-java (base-name)
  "Translate the named MiniJava program to equivalent Lisp"
  (let ((java-name (concatenate 'string base-name ".java"))
        (lisp-name (concatenate 'string base-name "-compiled.lisp")))
    (with-open-file (os lisp-name :direction :output :if-exists :supersede)
      (mj-l-preamble base-name os)
      (mj-translate (parse-java java-name) os))))

(defun mj-translate (ast os)
  "Translate an MJ program from the AST"
  (let ((env (setup-mj-env ast)))
    (mj-l-methods env os)
    (mj-l-classes env os)
    (format os "~%~%;; Main routine")
    (pprint (mj-l-statement (fourth (second ast)) env) os)))

(defun mj-l-preamble (base-name os)
  "Add a preamble to the output file"
  (format os "~%;; === Translated from ~A ===" base-name)
  (format os "~%(unless (boundp '*mj-stdout*) (setf *mj-stdout* t))")
  (format os "~%(unless (boundp '*mj-stdin*)  (setf *mj-stdin* nil))")
  (pprint 
   '(defun mj-l-read ()
     "Read a MiniJava integer"
     (let ((result (if *mj-stdin*
                       (read *mj-stdin*)
                       (progn
                         (format t "~%Enter number: ")
                         (read)))))
       (if (integerp result)
           result
           0)))
   os)
  (format os "~%"))

;; vtables are mjl-Class
;; constructors are mjl-Class+
;; methods are mjl-Class-Method
;; locals are declared in let statements
;; objects are represented by arrays

;; Define all the methods first (done)
;; Then define the vtables (done)
;; Then define the constructors (done)
;; Then translate the main statement (done)


;; --- Construct names for vtables, constructors, methods, locals ---

(defun mj-l-method-name (class-name method-name)
  "Create a symbol associated with this method"
  (intern (format nil "mjl-~A-~A" class-name method-name)))

(defun mj-l-local-name (slot)
  "Create a symbol associated with a stack variable or argument"
  (intern (format nil "L~A" slot)))

(defun mj-l-constructor-name (class-name)
  "Create a symbol associated with a class constructor"
  (intern (format nil "mjl-~A+" class-name)))

(defun mj-l-vtable-name (class-name)
  "Create a symbol associated with a class vtable"
  (intern (format nil "mjl-~A" class-name)))

(defun mj-l-type-default (type)
  (if (eq type 'IntType)
      0
      nil))


;; --- Translate methods ---

(defun mj-l-methods (env os)
  "Translate all methods."
  (maphash #'(lambda (key method)
               (mj-l-method (car key) (cdr key) method env os))
           (mj-env-methods env)))

(defun mj-l-method (class-name method-name method env os)
  "Translate one method."
  (let* ((class       (mj-method-class  method))
         (layout      (mj-method-layout method))
         (this-layout (cdr (assoc class (mj-env-classes env)))))
    (format os "~%~%;; ~A::~A" class-name method-name)
    (push `(,layout ,this-layout ,class) (mj-env-stack env))
    (pprint
     `(defun ,(mj-l-method-name class-name method-name)
       ,(mj-l-method-args method)
       (let ,(mj-l-method-frame method)
         ,@(mj-l-statements (mj-method-code method) env)
         ,(mj-l-exp (mj-method-value method) env)))
     os)
    (pop (mj-env-stack env))))

(defun mj-l-method-args (method)
  "Create a list of argument names"
  (let ((args nil))
    (dotimes (i (length (mj-method-formals method)))
      (push (mj-l-local-name (1+ i)) args))
    (cons 'this (nreverse args))))

(defun mj-l-method-frame (method)
  "Build let statement for locals"
  (let ((vars nil))
    (map-visible-vars 
     #'(lambda (name slot type)
         (when (> slot (length (mj-method-formals method)))
           (push (list (mj-l-local-name slot)
                       (mj-l-type-default type))
                 vars)))
     (mj-method-layout method))
    vars))


;; --- Build class vtables and constructors ---

(defun mj-l-classes (env os)
  "Produce vtables and constructors"
  (dolist (class-pair (mj-env-classes env))
    (mj-l-class (car class-pair) (cdr class-pair) env os)))

(defun mj-l-class (class-name layout env os)
  "Produce vtable and constructor for one class"
  (mj-l-vtable class-name env os)
  (mj-l-constructor class-name layout env os))

(defun mj-l-vtable-setup (vtable-map class-name env)
  "Set up the name -> method map for the class"
  (when class-name
    (mj-l-vtable-setup vtable-map 
                       (cdr (assoc class-name (mj-env-parents env)))
                       env)
    (maphash #'(lambda (key val)
                 (when (eq (car key) class-name)
                   (setf (gethash (cdr key) vtable-map) class-name)))
             (mj-env-methods env))))

(defun mj-l-vtable (class-name env os)
  "Produce vtable for one class"
  (let ((vtable-map  (make-hash-table))
        (vtable-name (mj-l-vtable-name class-name)))
    (mj-l-vtable-setup vtable-map class-name env)
    (format os "~%~%;; Vtable for ~A" class-name)
    (pprint `(setf ,vtable-name (make-hash-table)) os)
    (maphash #'(lambda (method-name class-name)
                 (pprint `(setf (gethash ',method-name ,vtable-name)
                           #',(mj-l-method-name class-name method-name))
                         os))
             vtable-map)))

(defun mj-l-constructor (class-name layout env os)
  "Build a class constructor function."
  (let ((initializers nil))
    (map-vars #'(lambda (name slot type)
                  (push `(setf (elt obj ,slot) ,(mj-l-type-default type))
                        initializers))
              layout)
    (format os "~%~%;; Constructor for ~A" class-name)
    (pprint `(defun ,(mj-l-constructor-name class-name) ()
              (let ((obj (make-array '(,(1+ (get-var-count layout))))))
                (setf (elt obj 0) ,(mj-l-vtable-name class-name))
                ,@initializers
                obj))
            os)))
              

;; --- Translate statements and expressions ---

(defun mj-l-statements (statements env)
  "Translate a statement list."
  (let ((acc nil))
    (dolist (statement statements)
      (push (mj-l-statement statement env) acc))
    (nreverse acc)))

(defun mj-l-get-var (var-name env)
  "Retrieve the variable."
  (setf var-name (id-name var-name))
  (when (not (mj-env-stack env))
    (mj-report-error env "Cannot access variable ~a in main routine" var-name))
  (let* ((stack-frame  (car (mj-env-stack env)))
         (stack-layout (first  stack-frame))
         (this-layout  (second stack-frame))
         (stack-slot   (get-var-slot var-name stack-layout))
         (this-slot    (get-var-slot var-name this-layout)))
    (if stack-slot
        (mj-l-local-name stack-slot)
        `(elt this ,this-slot))))

(defun mj-l-call (ast env)
  "Translate a function call."
  (labels ((e (expr) (mj-l-exp expr env)))
    `(let* ((obj ,(e (second ast)))
            (vtable (elt obj 0)))
      (funcall (gethash ',(id-name (third ast)) vtable)
       obj ,@(mapcar #'e (cdr (fourth ast)))))))

(defun mj-l-statement (ast env)
  "Translate a MiniJava statement."
  (labels 
      ((e (i)  (mj-l-exp (nth i ast) env))
       (s (i)  (mj-l-statement (nth i ast) env)))
    (case (car ast)
      (If          `(if ,(e 1) ,(s 2) ,(s 3)))
      (While       `(while ,(e 1) ,(s 2)))
      (Print       `(format *mj-stdout* "~A~%" ,(e 1)))
      (Assign      `(setf ,(mj-l-get-var (second ast) env) ,(e 2)))
      (ArrayAssign `(setf (elt ,(mj-l-get-var (second ast) env) ,(e 2)) 
                     ,(e 3)))
      (Block       `(progn ,@(mj-l-statements (cdadr ast) env)))
      (t
       (pprint ast)
       (error "Unexpected statement")))))

(defun mj-l-exp (ast env)
  "Translate a MiniJava expression"
  (labels 
      ((c  (v) (eq (car ast) v))
       (e1 ()  (mj-l-exp (second ast) env))
       (e2 ()  (mj-l-exp (third  ast) env)))
    (cond 
      ((eq ast 'this) 'this)
      ((c 'Not)       `(not ,(e1)))
      ((c 'And)       `(and ,(e1) ,(e2)))
      ((c 'LessThan)  `(< ,(e1) ,(e2)))
      ((c 'Plus)      `(+ ,(e1) ,(e2)))
      ((c 'Minus)     `(- ,(e1) ,(e2)))
      ((c 'Times)     `(* ,(e1) ,(e2)))
      ((c 'IntegerLiteral) (second ast))
      ((c 'BooleanLiteral) (eq (second ast) 'true))
      ((c 'ArrayLookup)    `(elt ,(e1) ,(e2)))
      ((c 'ArrayLength)    `(length ,(e1)))
      ((c 'NewArray)       `(make-array (list ,(e1)) :initial-element 0))
      ((c 'NewObject)      `(,(mj-l-constructor-name (id-name (second ast)))))
      ((c 'Call)           (mj-l-call ast env))
      ((c 'Read)           `(mj-l-read))
      ((c 'IdentifierExp)  (mj-l-get-var (second ast) env)))))