
; recursive descent parser. refer to the wikipedia article.

(define (filter-vector-ref binary-tree)
  (letrec
    ((filter-vector-ref-fn-args
      (lambda (binary-tree)
        (if (null? binary-tree)
          '()
          (cons
            (filter-vector-ref (car binary-tree))
            (filter-vector-ref (cdr binary-tree)))))))
    ; also converts $neg back to a unary minus
    (cond
      ((null? binary-tree) '())
      ((eq? binary-tree '$neg) '-)
      ((not (pair? binary-tree)) binary-tree)
      ((function? (car binary-tree))
        (cons (car binary-tree)
	      (filter-vector-ref-fn-args (cdr binary-tree))))
      (else
        (if (= (length binary-tree) 2)
	  (if (array-var? (car binary-tree))
	    (list
	      'vector-ref
	      (car binary-tree)
	      (filter-vector-ref (cadr binary-tree)))
            (cons
              (filter-vector-ref (car binary-tree))
              (filter-vector-ref (cdr binary-tree))))
          (cons
            (filter-vector-ref (car binary-tree))
            (filter-vector-ref (cdr binary-tree))))))))

(define (filter-vector-set expression)
  (if (pair? expression)
    (if (= (length expression) 3)
      (if (eq? (car expression) 'set!)
        (if (pair? (cadr expression))
          (if (array-var? (car (cadr expression)))
            (list 'vector-set!
	          (car (cadr expression))
	          (cadr (cadr expression))
	          (cadr (cdr expression)))
	    expression)
          expression)
        expression)
      expression)
    expression))

(define (parse-expression leave-off-final-close-paren?)
  (set! tokens '())
  (let loop ((token (get-token)))
    (let
      ((next-token (lookahead)))
      (if (not (or
        (and (eq? token close-paren-tok)
          (identifier? next-token))
        (and (eq? token close-bracket-tok) (identifier? next-token))
        (and (eq? token close-paren-tok) (eq? next-token semi-colon-tok))
        (and (eq? token close-bracket-tok) (eq? next-token semi-colon-tok))
        (and (identifier? token) (eq? next-token semi-colon-tok))
        (and (identifier? token) (identifier? next-token))))
        (begin
          (set! tokens (cons token tokens))
          (loop (get-token)))
        (if (not leave-off-final-close-paren?)
          (set! tokens (cons token tokens)))))) ; add last token

  (set! tokens (reverse tokens))

  (if (not leave-off-final-close-paren?)
    (if (eq? (lookahead) semi-colon-tok)
      (get-token)))

  (if (not (balanced-parens-and-brackets? (list->vector tokens)))
    (log-error 'MISMATCHED_PARENS '()))

; (display tokens) ; debug
; (newline)

  (display
    (filter-vector-ref
      (filter-vector-set (shunt tokens)))))

(define (indent level)
  (if (> level 0)
    (begin
      (display "  ")
      (indent (- level 1)))))

(define (parse-include)
  (expect include-tok)
  (expect less-than-tok)
    (let loop ((token (get-token)))
      (if (not (eq? token greater-than-tok))
        (loop (get-token)))))

(define constants (make-hash))

(define (define-constant-name-value name value)
  (hash-set! constants name value))

(define (get-constant-value name)
  (let
    ((value (hash-ref constants name)))
    (if (not value)
      (begin
        (log-error 'UNDEFINED_CONSTANT name)
	0) ; default
      (cadr value))))

(define (constant? x)
  (hash-ref constants x))

(define global-variables (make-hash))

(define arrays '())
(define fn-arg-arrays '())

(define (array-var? x)
  (let
    ((found (memq x arrays)))
    (if found
      found
      (memq x fn-arg-arrays))))

(define (define-global-var-name-value name value)
  (hash-set! global-variables name value))

(define (global-var? x)
  (hash-ref global-variables x))

(define local-variables '())
(define formal-parameters '())

(define (define-local-var-name-value name value)
  (set! local-variables (cons (list name value) local-variables)))

(define (local-var? x)
  (let
    ((found (memq x formal-parameters)))
    (if found
      found
      (assq x local-variables))))


(define (parse-define)
  (expect define-tok)
  (let
    ((name (get-token))
     (value (get-token)))
    (if (not (number? value))
      (begin
        (log-error 'NUMBER_EXPECTED value)
        (set! value 0)))
    (display "(define ")
    (display name)
    (display " ")
    (display value)
    (display ")")
    (newline)
    (display-comments 0)
    (define-constant-name-value name value)))

(define (parse-includes-and-defines)
  (let loop ()
    (if (eq? (lookahead) pound-tok)
      (begin
        (get-token) ; #
        (if (eq? (lookahead) include-tok)
          (parse-include)
          (parse-define))
        (loop)))))

(define (parse-variable-definition top-level)
  (expect integer-tok)
  (let
    ((name (get-token))
     (value '())
     (value_name '()))
    ; default integer size 
    (if (eq? (lookahead) open-bracket-tok)
      (begin ; array
        (get-token)
        (set! value (get-token))
	(set! arrays (cons name arrays))
        (if (not (number? value))
          (begin
            (set! value (get-constant-value value))
            (if (not value)
              (begin
                (log-error 'UNDEFINED_CONSTANT name)
                ; error default 
                (set! value 1)))))
        (expect close-bracket-tok)))
    (expect semi-colon-tok)
    (display "(") (display name) (display " ")
    (if (not (null? value)) ; array definition
      (begin
        (display "(make-vector ") (display value)
          (display " 0))") (newline)) ; initialize vector to zeros 
      (begin ; variables local to a procedure or function 
        (display "0)") (newline)))
    (if top-level
      (begin
        (define-global-var-name-value name value)
        (display-comments 1))
      (begin
        (define-local-var-name-value name value)
        (display-comments 4)))))

(define (parse-variable-definitions top-level)
  (if (not top-level)
    (begin
      (set! local-variables '())
      (indent 3)))
  (display "(let (")
  (newline)
  (let loop ()
    (if (lookahead-var)
      (begin
        (if top-level
          (indent 1)
          (indent 4))
        (parse-variable-definition top-level)
        (loop))))
  (if top-level
    (indent 1)
    (indent 4))
  (display ")")
  (newline))

(define (parse-if-statement level)
  (indent level)
  (display "(if (__test ")
  (if (not (eq? (lookahead) open-paren-tok))
    (log-error 'EXPECT_TOKEN open-paren-tok))
  (parse-expression #f)
  (display ")")
  (newline)
  (parse-statement (+ level 1))
  (if (eq? (lookahead) else-tok)
    (begin
      (get-token) ; else
      (newline)
      (parse-statement (+ level 1))))
  (display ")"))

(define (parse-while-statement level)
  (indent level)
  (display "(let loop ()") (newline)
  (indent (+ level 1))
  (display "(if (__test ")
  (if (not (eq? (lookahead) open-paren-tok))
    (log-error 'EXPECT_TOKEN open-paren-tok))
  (parse-expression #f)
  (display ")")
  (newline)
  (indent (+ level 2))
  (display "(begin")
  (newline)
  (parse-statement (+ level 3))
  (newline)
  (indent (+ level 3))
  (display "(loop))))"))

(define (parse-repeat-statement level)
  (indent level)
  (display "(let loop ()")
  (newline)
  (indent (+ level 1))
  (display "(begin")
  (newline)
  (expect begin-tok)
  (let loop ()
    (if (not (eq? (lookahead) end-tok))
      (begin
        (parse-statement (+ level 2))
        (newline)
        (loop))))
  (expect end-tok)
  (expect while-tok)
  (if (not (eq? (lookahead) open-paren-tok))
    (log-error 'EXPECT_TOKEN open-paren-tok))
  (indent (+ level 2))
  (display "(if (__test ")
  (parse-expression #f)
  (display ")")
  (newline)
  (newline)
  (indent (+ level 3))
  (display "(loop))))")
  (newline))

(define (parse-for-statement level)
  (let
    ((control-var '())
     (incr '()))
    (expect open-paren-tok)
    (indent (+ level 1))
    (display "(begin")
    (newline)
    (indent (+ level 1))
    (set! control-var (lookahead))
    (parse-expression #f)
    (newline)
    (indent (+ level 1))
    (display "(let loop ()")
    (newline)
    (indent (+ level 2))
    (display "(if (__test ")
    (parse-expression #f)
    (display ")")
    (newline)
    (indent (+ level 3))
    (display "(begin")
    (newline)
    (if (not (eq? (get-token) control-var))
      (log-error 'CONTROL_VAR_MISMATCH '()))
    (set! incr (get-token))
    (if (not (or (eq? incr succ-tok) (eq? incr pred-tok)))
      (log-error 'EXPECTING_INCR_DECR '()))
    (expect close-paren-tok)
    (parse-statement (+ level 4))
    (newline)
    (indent (+ level 4))
    (if (eq? incr succ-tok)
      (display (list 'set! control-var (list '+ control-var 1))) 
      (display (list 'set! control-var (list '- control-var 1)))) 
    (newline)
    (indent (+ level 4))
    (display "(loop)))))")
    (newline)))

(define (parse-break-statement)
  (get-token)
  (expect semi-colon-tok))

(define (parse-case-list-element level)
  (let
    ((number 0))
    (if (not (eq? (lookahead) end-tok))
      (begin
        (expect case-tok)
        (set! number (get-token))
        (if (not (number? number))
          (set! number (get-constant-value number)))
        (expect colon-tok)
        (indent level)
        (display "((") (display number) (display ")") (newline)
        (let loop ()
          (if (and (not (eq? (lookahead) end-tok))
                   (not (eq? (lookahead) case-tok)))
            (begin
              (if (eq? (lookahead) break-tok)
                (parse-break-statement)
                (begin
                  (parse-statement (+ level 1))
                  (if (not (eq? (lookahead) break-tok))
                    (newline))))
              (loop))))
        (display ")")
        (newline)))))

(define (parse-case-list-elements level)
  (if (not (eq? (lookahead) end-tok))
    (begin
      (parse-case-list-element level)
      (parse-case-list-elements level))))

(define (parse-case-statement level)
  (if (not (eq? (lookahead) open-paren-tok))
    (log-error 'EXPECT_TOKEN open-paren-tok))
  (indent level)
  (display "(case")
  (newline)
  (indent (+ level 1))
  (parse-expression #f)
  (newline)
  (expect begin-tok)
  (parse-case-list-elements (+ level 1))
  (expect end-tok)
  (indent level)
  (display ")"))

(define (get-4-chars s)
  (if (< (length s) 4)
    s
    (cons
      (+
        (* (char->integer (car s)) 256 256 256)
        (* (char->integer (cadr s)) 256 256)
        (* (char->integer (cadr (cdr s))) 256)
           (char->integer (cadr (cddr s))))
      (get-4-chars (cddr (cddr s))))))

(define (display-packed-string s level)
  (if (not (null? s))
    (let
      ((x (car s)))
      (indent level)
      (if (number? x)
	(begin
          (display "(__put4chars ") (display x) (display ")"))
	(begin ; a lone character
          (display "(putchar ") (display (char->integer x)) (display ")")))
      (newline)
      (display-packed-string (cdr s) level))))

(define (parse-statement level)
  (let
    ((token (lookahead)))
    (display-comments level)
    (cond
      ((eq? token begin-tok)
        (indent level)
        (display "(begin") (newline)
        (parse-compound-statement (+ level 1))
        (display ")"))
      ((eq? token if-tok)
        (get-token)
        (parse-if-statement level))
      ((eq? token while-tok)
        (get-token)
        (parse-while-statement level))
      ((eq? token do-tok)
        (get-token)
        (parse-repeat-statement level))
      ((eq? token for-tok)
        (get-token)
        (parse-for-statement level))
      ((eq? token switch-tok)
        (get-token)
        (parse-case-statement level))
      ((eq? token end-tok)
        '()) ; do nothing 
      ((eq? token return-tok)
        (get-token)
        (if (eq? (lookahead) semi-colon-tok)
          (begin ; procedure return get semicolon 
            (get-token)
            (indent level)
            (display "(return-from-procedure)"))
          (begin ; function return 
            (indent level)
            (display "(return ")
            (parse-expression #f)
            (display ")"))))
       ((eq? token printf-tok)
         ; transform printf into either write-int or calls to string packer
         (get-token)
         (expect open-paren-tok)
         (if (not (string? (lookahead))) 
           (begin
	     (log-error 'STRING_EXPECTED (lookahead))
	     (get-token)
	     (get-token))
           (if (string=? (lookahead) "%d") 
             (begin
               (get-token) ; "%d"
	       (get-token) ; ,
               (indent level)
               (display "(__write_integer ")
               (parse-expression #t)
               (display ")"))
             (begin
               (indent level)
               (display "(begin") (newline)
               (display-packed-string
                 (get-4-chars (string->list (get-token))) level)
               (display ")")
               (get-token)))) ; ) 
         (expect semi-colon-tok))
       ((identifier? token)
         (indent level)
         (parse-expression #f))
       (else
         (log-error 'BAD_STATEMENT token)))))

(define (parse-statements level)
  (let loop ()
    (if (not (eq? (lookahead) end-tok))
      (begin
        (parse-statement level)
        (if (not (eq? (lookahead) end-tok))
          (newline))
        (loop)))))

(define (parse-compound-statement level)
  (if (not (eq? (get-token) begin-tok))
    (log-error 'EXPECT_TOKEN begin-tok))
  (parse-statements level)
  (expect end-tok))

(define (parse-block name)
  (let
    ((block-has-vars? #f)) ; formals offset is number of formal parameters 
    (if (lookahead-var)
      (begin
        (set! block-has-vars? #t)
        (parse-variable-definitions #f)))
    (parse-statements 3)
    (if block-has-vars?
      (display ")))")
      (display "))"))))

(define (parse-formal-parameter)
  (expect integer-tok)
  (let
    ((name (get-token))
     (ret '()))
    (set! formal-parameters (cons name formal-parameters))
    (if (eq? (lookahead) open-bracket-tok)
      (begin ; reference var get open bracket 
        (get-token)
        (expect close-bracket-tok)
	(set! fn-arg-arrays (cons name fn-arg-arrays))
	(set! ret (list name)))
      (set! ret name))
  ; TODO test for max limit of 32 parameters
    (display name)
    ret))

(define (parse-formal-parameters)
  (set! fn-arg-arrays '()) ; reset
  (set! formal-parameters '()) ; reset
  (let
    ((ret '()))
    (let loop ()
      (if (not (eq? (lookahead) close-paren-tok))
        (begin
          (set! ret (cons (parse-formal-parameter) ret))
          (if (eq? (lookahead) comma-tok)
            (begin
              (get-token)
              (display " ")
              (loop))))))
    ret))

(define (forward?)
  (eq? (lookahead) semi-colon-tok))

(define functions (make-hash))
; populate predefined functions
(hash-set! functions '__put4chars '(x))
(hash-set! functions '__write_int_digit '(x))
(hash-set! functions '__write_integer '(x))
(hash-set! functions 'getchar '())
(hash-set! functions 'putchar '(ch))
(hash-set! functions 'abs '(x))
(hash-set! functions 'exit '(n))

(define (function? x)
  (if (symbol? x)
    (hash-ref functions x)
    #f))

(define (parse-function)
  (get-token) ; int
  (let
    ((name (get-token)))
    (expect open-paren-tok)
    (newline)
    (indent 2) (display "(") (display name) (newline)
    (indent 3) (display "(lambda (")
    (hash-set! functions
      name
      (reverse (parse-formal-parameters)))
    (expect close-paren-tok)
    (display ")") (newline)
   (if (not (forward?))
     (begin
       (expect begin-tok)
       (parse-block name)
       (expect end-tok))
     ; forward 
     (begin
       (expect semi-colon-tok)
       (display "__forward))")
       (newline)))
   ))

(define (parse-procedure)
  (get-token) ; void
  (let
    ((name (get-token)))
    (expect open-paren-tok)
    (newline)
    (indent 2) (display "(") (display name) (newline)
    (indent 3) (display "(lambda (")
    (hash-set! functions
      name
      (reverse (parse-formal-parameters)))
    (expect close-paren-tok)
    (display ")") (newline)
   (if (not (forward?))
     (begin
       (expect begin-tok)
       (parse-block name)
       (expect end-tok))
     (begin ; forward 
       (expect semi-colon-tok)
       (display "__forward))")
       (newline)))
   ))

(define (parse-procedures-and-functions)
  (let loop ()
    (if (or (lookahead-procedure)
	    (lookahead-function))
      (begin
        (if (lookahead-procedure)
          (parse-procedure)
          (parse-function))
        (loop)))))

(define (include-put4chars)
  (indent 2) (display "(__put4chars") (newline)
  (indent 3) (display "(lambda (x)") (newline)
  (indent 3) (display "(putchar (shr x 24))") (newline)
  (indent 3) (display "(putchar (bitwise-and (shr x 16) 255))") (newline)
  (indent 3) (display "(putchar (bitwise-and (shr x 8) 255))") (newline)
  (indent 3) (display "(putchar (bitwise-and x 255))") (newline)
  (indent 3) (display "(return-from-procedure)))") (newline))

(define (include-write-int-digit)
  (indent 2) (display "(__write_int_digit") (newline)
  (indent 3) (display "(lambda (n)") (newline)
  (indent 3) (display "(if (__test (> n 0))") (newline)
  (indent 4) (display "(begin") (newline)
  (indent 5) (display "(__write_int_digit (quotient n 10))") (newline)
  (indent 5) (display "(putchar (+ (remainder n 10) 48))))") (newline)
  (indent 3) (display "(return-from-procedure)))") (newline))

(define (include-write-integer)
  (indent 2) (display "(__write_integer") (newline)
  (indent 3) (display "(lambda (n)") (newline)
  (indent 3) (display "(if (__test (= n 0))") (newline)
  (indent 4) (display "(begin") (newline)
  (indent 5) (display "(putchar 48)") (newline)
  (indent 5) (display "(return-from-procedure)))") (newline)
  (indent 3) (display "(if (__test (< n 0))") (newline)
  (indent 4) (display "(begin") (newline)
  (indent 5) (display "(putchar 45)") (newline)
  (indent 5) (display "(if (__test (&& (= (bitwise-and n 65535) 0) (= (shr n 16) (- 32768))))") (newline)
  (indent 6) (display "(begin") (newline)
  (indent 7) (display "(begin") (newline)
  (indent 7) (display "(__put4chars 842085431)") (newline)
  (indent 7) (display "(__put4chars 876098358)") (newline)
  (indent 7) (display "(putchar 52)") (newline)
  (indent 7) (display "(putchar 56))") (newline)
  (indent 7) (display "(return-from-procedure)))") (newline)
  (indent 5) (display "(__write_int_digit (- n)))") (newline)
  (indent 4) (display "(__write_int_digit n))") (newline)
  (indent 3) (display "(return-from-procedure)))") (newline))

(define (parse-program)
  (initialize-lex)
  (parse-includes-and-defines)
  (if (lookahead-var)
    (parse-variable-definitions #t))
  (indent 1)
  (display "(letrec (")
  (newline)
  (include-put4chars)
  (include-write-int-digit)
  (include-write-integer)
  (if (or (lookahead-procedure)
	  (lookahead-function))
    (parse-procedures-and-functions))
  (if (not (null? (get-token)))
    (log-error 'REST_OF_PROGRAM_IGNORED '()))
  (display ")")
  (newline)
  (display "    (main)") ; call main
  (if (empty-hash-table? global-variables 0)
    (display ")") ; no global vars 
    (display "))"))
  (newline))

(parse-program)
;(display functions) (newline) ; debug
;(display arrays) (newline)
