まるで手続き型のschemeプログラム

明日のゼミの課題だった，Ｃを解析して，ニーモニック風のコードを出すプログラムがとりあえず完成．
しかしまるで手続き型のよう．しかもときどきperlかのようなところもある．
しかも”コンパイルエラー”は未実装．
とまぁ問題点を挙げればきりがない．しかも，そもそもコンパイラでは括弧なし四則演算しか対応していない．
ちなみに”コンパイルエラー”に該当するところは普通にgaucheのエラーになるw
例外を使えばそこはできそうなんだが，とりあえず眼球が痛すぎるので，本日はここまで．長いし，汚いけど載せちゃおう．

;;make list of program
(define (makeProgramlist filename)
  (call-with-input-file filename
    (lambda (in)
      (split-programlist
       (string-split (port->string in) char-whitespace?)))))

(define (split-programlist lis)
  (let loop ((new_programlist '())
             (old_programlist lis))
    (cond [(null? old_programlist) new_programlist]
          [(rxmatch-case (car old_programlist)
             [#/(^[\W])(\w+)/ (all st1 st2)
              (loop (append (append new_programlist (list st1)) (list st2))
                    (cdr old_programlist))]
             [#/(\w+)([\W]$)/ (all st1 st2)
              (loop (append (append new_programlist (list st1)) (list st2))
                    (cdr old_programlist))])]
          [else (loop (append new_programlist (list (car old_programlist)))
                      (cdr old_programlist))])))

;;funtion name
(define (cutNameId programlist)
  (cadr programlist))

;;parseParameter
(define (parseParameter lis)
  (if (string=? "(" (car lis))
      (let loop ((parameterlist (cdr lis))
                 (parameters '())
                 (offset 8))
        (cond [(string=? ")" (car parameterlist)) parameters]
              [(string=? (car parameterlist) "int")
               (loop (cddr parameterlist)
                     (cons (cons (cadr parameterlist) offset) parameters)
                     (+ offset 4))]
              [(string=? (car parameterlist) ",")
               (loop (cdr parameterlist)
                     parameters
                     offset)]
              [else #f]))
      #f))

;;parseFuntion
(define (parseFunction lis index)
  (define (parseBlock lis)
    (let innerfuncion ((lis1 lis)
                       (lis2 '()))
      (if (string=? "{" (list-ref lis1 index))
          (begin
            (inc! index)
            (set! lis2 (parseStatement lis1)))
          #f)
      (if (string=? "}" (list-ref lis1 index))
          (begin
            (inc! index)
            lis2)
          #f)
      ))
  (define (parseStatement lis)
    (let innerfuncion ((lis1 lis)
                       (lis2 '()))
      (if (string=? "return" (list-ref lis1 index))
          (begin
            (inc! index)
            (set! lis2 (cons "RET" (parseReturnStatement lis1))))
          #f)
      (if (string=? ";" (list-ref lis index))
          (begin
            (inc! index)
            lis2)
          #f)
      ))
  (define (parseReturnStatement lis)
    (list (parseExpression lis)))
  (define (parseExpression lis)
    (let loop ((result (parseTerm lis))
               (experession lis))
      (cond [(>= index (length experession)) result]
            [(string=? "+" (list-ref experession index))
             (inc! index)
             (loop (three-cons "ADD" result (parseTerm experession))
                   experession)]
            [(string=? "-" (list-ref experession index))
             (inc! index)
             (loop (three-cons "SUBTRACT" result (parseTerm experession))
                   experession)]
            [else result])))
  (define (parseTerm lis)
    (let loop ((result (parseFactor lis))
               (term lis))
      (cond [(>= index (length term)) result]
            [(string=? "*" (list-ref term index))
             (inc! index)
             (loop (three-cons "MULTIPLY" result (parseFactor term))
                   term)]
            [(string=? "/" (list-ref term index))
             (inc! index)
             (loop (three-cons "DIVIDE" result (parseFactor term))
                   term)]
            [else result])))
  (define (parseTerm lis)
    (let loop ((result (parseFactor lis))
               (term lis))
      (cond [(>= index (length term)) result]
            [(string=? "*" (list-ref term index))
             (inc! index)
             (loop (three-cons "MULTIPLY" result (parseFactor term))
                   term)]
            [(string=? "/" (list-ref term index))
             (inc! index)
             (loop (three-cons "DIVIDE" result (parseFactor term))
                   term)]
            [else result])))
  (define (parseFactor lis)
    (cond [(#/\w+/ (list-ref lis index))
           (inc! index)
           (list-ref lis (- index 1))]
          [else '()]))
  (parseBlock lis)
  )

(define (three-cons factor1 factor2 factor3)
  (cons factor1 (cons factor2 (cons factor3 '()))))

;;search-parameter of funtion
(define (search-parameter parameters parameter)
  (cond [(null? parameters) #f]
        [(string=? parameter (caar parameters))
         (cdar parameters)]
        [else (search-parameter (cdr parameters) parameter)]))

;;generateCode
(define (generateCode lis parameters)
  (let loop ((functionlist lis))
    (if (list? functionlist)
        (cond [(string=? "RET" (car functionlist))
               (loop (cadr functionlist))
               (print "    pop eax")
               (print "    ret")]
              [(string=? "ADD" (car functionlist))
               (loop (cadr functionlist))
               (loop (caddr functionlist))
               (print "    pop ecx")
               (print "    pop eax")
               (print "    add ecx, eax")]
              [(string=? "SUBTRACT" (car functionlist))
               (loop (cadr functionlist))
               (loop (caddr functionlist))
               (print "    pop ecx")
               (print "    pop eax")
               (print "    sub ecx, eax")]
              [(string=? "MULTIPLY" (car functionlist))
               (loop (cadr functionlist))
               (loop (caddr functionlist))
               (print "    pop ecx")
               (print "    pop eax")
               (print "    mul ecx, eax")]
              [(string=? "DIVIDE" (car functionlist))
               (loop (cadr functionlist))
               (loop (caddr functionlist))
               (print "    pop ecx")
               (print "    pop eax")
               (print "    div ecx, eax")]
              [else (print "ERROR")])
        (cond [(#/[a-z_]+/i functionlist)
               (cond [(search-parameter parameters functionlist) =>
                      (cut format #t "    mov [SP+ ~a], eax\n    push eax\n" <>)]
                     [else #f])]
              [(#/\d+/ functionlist)
               (format #t "    mov #~a, eax\n    push eax\n" functionlist)]
              [else #f])
        )
    ))

;;search-block
(define (search-block programlist)
  (let loop ((index 0)
             (lis programlist))
    (cond [(>= index (length lis)) #f]
          [(string=? "{" (car lis)) index]
          [else (loop (+ index 1) (cdr lis))])))

(split-programlist testfuncion)
(define testfuncion (makeProgramlist "example.txt"))

(define (SimpleCompiler filename)
  (let* ((programlist (makeProgramlist filename))
         (nameId (cutNameId programlist))
         (parameters (parseParameter (cddr programlist)))
         (index (search-block programlist)))
    (newline)
    (format #t "~a\n" nameId)
    (generateCode (parseFunction programlist index)
                  parameters)))
(SimpleCompiler "example.txt")

gosh>
function
    mov [SP+ 12], eax
    push eax
    mov #1, eax
    push eax
    mov [SP+ 8], eax
    push eax
    pop ecx
    pop eax
    mul ecx, eax
    pop ecx
    pop eax
    add ecx, eax
    pop eax
    ret
#<undef>