;;; --- Tokenizer adapter functions ---

;; Make sure the *class* of the token matches the case sensitivity of
;; the current Lisp (so we can always test (eq sym 'if), for example, rather
;; than writing (eq sym '|if|) for portability to ANSI Lisps
;;
(if (string= "foo" (symbol-name 'foo))
    (defun mj-naturalize-symbol (x)   ; Modern Lisp version
      x)
    (defun mj-naturalize-symbol (x)   ; ANSI Lisp version
      (if (symbolp x)
          (intern (string-upcase x))
          x)))

;; Convert the token class to something "natural" for the Lisp
(defun normalize-token-type (x)
  (cons (mj-naturalize-symbol (car x)) (cdr x)))

;; Translate from lex to simple-lex style token types
(defun translate-token-type (x)
  (setf x (normalize-token-type x))
  (if (null (car x))
      'eof
      (case (car x)
        (&&      'and)
        (iconst  'num)
        (fconst  (error "Cannot process floating point numbers"))
        (bconst  (second x))
        (id      (if (member (second x) '(|int| |boolean|))
                     (mj-naturalize-symbol (second x))
                     'id))
        ((main String System out println) 'id)
        (otherwise (car x)))))

;; Translate from lex to simple-lex style tokens
(defun translate-token (x)
  (setf x (normalize-token-type x))
  (if (null (car x))
      'eof
      (case (car x)
        (&&      'and)
        (iconst  `(num . ,(second x)))
        (fconst   (error "Cannot process floating point numbers"))
        (bconst   (second x))
        (id       (if (member (second x) '(|int| |boolean|))
                      (mj-naturalize-symbol (second x))
                      x))
        ((main String System out println)
         (setf (car x) 'id)
         x)
        (otherwise (car x)))))


;;; --- Interface functions (sitting on top of lex) ---

(defun parse-java (fname)
  "Parse a Java file and return the parse tree."
  (let ((tokens (fsl fname)))
    (labels ((lookahead () (translate-token-type (car tokens)))
             (get-token () (translate-token (pop tokens))))
      (setf (ll1-parser-lookahead *my-ll1*) #'lookahead)
      (setf (ll1-parser-get-token *my-ll1*) #'get-token)
      (handler-case
          (parse-ll1 *my-ll1*)
        (my-parse-error (pe)
          (format t "Position ~A: " (third (car tokens)))
          (format t (text pe))
          (format t "~%"))))))

(defun print-java (fname)
  "Parse a Java file and pretty-print the AST."
  (pprint (parse-java fname)))

(defun java-to-ast (basename)
  "Parse a Java file and write the AST to another file."
  (let ((javaname (format nil "~A.java" basename))
        (astname  (format nil "~A-AST.lisp" basename)))
    (with-open-file (str astname :direction :output :if-exists :supersede)
      (pprint 
       `(defparameter *ast* (quote ,(parse-java javaname))) str))))