;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; compiler.mes produces an i386 binary from the C produced by
;;; Nyacc c99.

;;; Code:

(cond-expand
 (guile-2
  (set-port-encoding! (current-output-port) "ISO-8859-1"))
 (guile)
 (mes
  (mes-use-module (nyacc lang c99 parser))
  (mes-use-module (mes elf-util))
  (mes-use-module (mes pmatch))
  (mes-use-module (mes elf))
  (mes-use-module (mes libc-i386))
  (mes-use-module (mes optargs))))

(define (logf port string . rest)
  (apply format (cons* port string rest))
  (force-output port)
  #t)

(define (stderr string . rest)
  (apply logf (cons* (current-error-port) string rest)))

(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))

(define (mescc)
  (parse-c99
   #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
   #:cpp-defs '(
                ("__GNUC__" . "0")
                ("__NYACC__" . "1")
                ("VERSION" . "0.4")
                ("PREFIX" . "")
                )
   #:xdef? gnuc-xdef?
   #:mode 'code
   ))

(define (write-any x)
  (write-char (cond ((char? x) x)
                    ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a\n" x) (integer->char #xaa))
                    ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
                    ((procedure? x)
                     (stderr "write-any: proc: ~a\n" x)
                     (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
                     barf)
                    (else (stderr "write-any: ~a\n" x) barf))))

(define (ast:function? o)
  (and (pair? o) (eq? (car o) 'fctn-defn)))

(define (.name o)
  (pmatch o
    ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
    ((param-decl _ (param-declr (ident ,name))) name)
    ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
    ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
    (_
     (format (current-error-port) "SKIP .name =~a\n" o))))

(define (.statements o)
  (pmatch o
    ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))

(define <info> '<info>)
(define <functions> '<functions>)
(define <globals> '<globals>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
(define* (make o #:key (functions '()) (globals '()) (locals '()) (function #f) (text '()))
  (pmatch o
    (<info> (list <info>
                  (cons <functions> functions)
                  (cons <globals> globals)
                  (cons <locals> locals)
                  (cons <function> function)
                  (cons <text> text)))))

(define (.functions o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <functions>))))

(define (.globals o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <globals>))))

(define (.locals o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <locals>))))

(define (.function o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <function>))))

(define (.text o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <text>))))

(define (info? o)
  (and (pair? o) (eq? (car o) <info>)))

(define (clone o . rest)
  (cond ((info? o)
         (let ((functions (.functions o))
               (globals (.globals o))
               (locals (.locals o))
               (function (.function o))
               (text (.text o)))
           (let-keywords rest
                         #f
                         ((functions functions)
                          (globals globals)
                          (locals locals)
                          (function function)
                          (text text))
                         (make <info> #:functions functions #:globals globals #:locals locals #:function function #:text text))))))

(define (push-global-ref globals)
  (lambda (o)
    (lambda (f g t d)
      (i386:push-global-ref (+ (data-offset o g) d)))))

(define (push-global globals)
  (lambda (o)
    (lambda (f g t d)
      (i386:push-global (+ (data-offset o g) d)))))

(define (push-ident globals locals)
  (lambda (o)
    (let ((local (assoc-ref locals o)))
      (if local (i386:push-local local)
          ((push-global globals) o)))))

(define (push-ident-ref globals locals)
  (lambda (o)
    (let ((local (assoc-ref locals o)))
      (if local (i386:push-local-ref local)
          ((push-global-ref globals) o)))))

(define (expr->arg info) ;; FIXME: get Mes curried-definitions
  (lambda (o)
    (pmatch o
      ((p-expr (fixed ,value)) (cstring->number value))
      ((p-expr (string ,string)) ((push-global-ref (.globals info)) string))
      ((p-expr (ident ,name))
       ((push-ident (.globals info) (.locals info)) name))

      ((array-refo (p-expr (fixed ,value)) (p-expr (ident ,name)))
       (let ((value (cstring->number value))
             (size 4)) ;; FIXME: type: int
         (lambda (f g t d)
           (append
            ((ident->base (.locals info)) name)
            (i386:value->accu (* size value)) ;; FIXME: type: int
            (i386:base-mem->accu) ;; FIXME: type: int
            (i386:push-accu) ;; hmm
            ))))
      ((ref-to (p-expr (ident ,name)))
       (lambda (f g t d)
         ((push-ident-ref (.globals info) (.locals info)) name)))
      ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
                        (abs-declr (pointer)))
             ,cast)
       ((expr->arg info) cast))
      (_
       (format (current-error-port) "SKIP expr->arg=~a\n" o)     
       0))))

(define (ident->accu info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local
          (list (lambda (f g t d)
                  (i386:local->accu local)))
          (list (lambda (f g t d)
                  (i386:global->accu (+ (data-offset o g) d))))))))

(define (accu->ident info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local
          (list (lambda (f g t d)
                  (i386:accu->local local)))
          (list (lambda (f g t d)
                  (i386:accu->global (+ (data-offset o g) d))))))))

(define (value->ident info)
  (lambda (o value)
    (let ((local (assoc-ref (.locals info) o)))
      (if local
          (list (lambda (f g t d)
                  (i386:value->local local value)))
          (list (lambda (f g t d)
                  (i386:value->global (+ (data-offset o g) d) value)))))))

(define (ident-address->accu info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local
          (list (lambda (f g t d)
                  (i386:local-address->accu local)))
          (list (lambda (f g t d)
                  (i386:global->accu (+ (data-offset o g) d))))))))

(define (ident->base info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local
          (list (lambda (f g t d)
                  (i386:local->base local)))
          (list (lambda (f g t d)
                  (i386:global->base (+ (data-offset o g) d))))))))

(define (expr->accu info)
  (lambda (o)
    (pmatch o
      ((p-expr (fixed ,value)) (cstring->number value))
      ((p-expr (ident ,name)) (car ((ident->accu info) name)))
      ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
      ((not (fctn-call . _)) ((ast->info info) o))
      ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
      ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
      (_
       (format (current-error-port) "SKIP expr->accu=~a\n" o)
       0)
      )))

(define (string->global string)
  (cons string (append (string->list string) (list #\nul))))

(define (ident->global name value)
  (cons name (int->bv32 value)))

(define (expr->global o)
  (pmatch o
    ((p-expr (string ,string)) (string->global string))
    (_ #f)))

(define (dec->hex o)
  (number->string o 16))

(define (byte->hex o)
  (string->number (string-drop o 2) 16))

(define (asm->hex o)
  (let ((prefix ".byte "))
    (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
        (let ((s (string-drop o (string-length prefix))))
          (map byte->hex (string-split s #\space))))))

(define (test->jump->info info)
  (define (jump type)
    (lambda (o)
      (let* ((text (.text info))
             (info (clone info #:text '()))
             (info ((ast->info info) o))
             (jump-text (lambda (body-length)
                          (list (lambda (f g t d) (type body-length))))))
       (lambda (body-length)
         (clone info #:text
                (append text
                        (.text info)
                        (jump-text body-length)))))))
  (lambda (o)
    (pmatch o
      ((lt ,a ,b) ((jump i386:jump-nc) o))
      ((gt ,a ,b) ((jump i386:jump-nc) o))
      ((ne ,a ,b) ((jump i386:jump-nz) o))
      ((eq ,a ,b) ((jump i386:jump-nz) o))
      ((not _) ((jump i386:jump-z) o))
      ((and ,a ,b)
       (let* ((text (.text info))
              (info (clone info #:text '()))

              (a-jump ((test->jump->info info) a))
              (a-text (.text (a-jump 0)))
              (a-length (length (text->list a-text)))

              (b-jump ((test->jump->info info) b))
              (b-text (.text (b-jump 0)))
              (b-length (length (text->list b-text))))

         (lambda (body-length)
           (clone info #:text
                  (append text
                          (.text (a-jump (+ b-length body-length)))
                          (.text (b-jump body-length)))))))
      ((array-ref . _) ((jump i386:jump-byte-z) o))
      ((de-ref _) ((jump i386:jump-byte-z) o))
      (_ ((jump i386:jump-z) o)))))

(define (cstring->number s)
  (if (string-prefix? "0" s) (string->number s 8)
      (string->number s)))

(define (ast->info info)
  (lambda (o)
    (let ((globals (.globals info))
          (locals (.locals info))
          (text (.text info)))
      (define (add-local name)
        (let ((locals (acons name (1+ (length (filter positive? (map cdr locals)))) locals)))
          locals))

      ;;(stderr "\nS=~a\n" o)
      ;; (stderr "  text=~a\n" text)
      ;; (stderr "   info=~a\n" info)
      ;; (stderr "   globals=~a\n" globals)
      (pmatch o
        (((trans-unit . _) . _) ((ast-list->info info) o))
        ((trans-unit . ,elements) ((ast-list->info info) elements))
        ((fctn-defn . _) ((function->info info) o))
        ((comment . _) info)
        ((cpp-stmt (define (name ,name) (repl ,value)))
         (stderr "SKIP: #define ~s ~s\n" name value)
         info)

        ;; ;
        ((expr-stmt) info)

        ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
        
        ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
         (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
                                   (clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
             (let* ((globals (append globals (filter-map expr->global expr-list)))
                    (info (clone info #:globals globals))
                    (args (map (expr->arg info) expr-list)))
               (clone info #:text
                      (append text (list (lambda (f g t d)
                                           (apply i386:call (cons* f g t d
                                                                   (+ t (function-offset name f)) args)))))
                      #:globals globals))))

        ((if ,test ,body)
         (let* ((text-length (length text))

                (test-jump->info ((test->jump->info info) test))
                (test+jump-info (test-jump->info 0))
                (test-length (length (.text test+jump-info)))

                (body-info ((ast->info test+jump-info) body))
                (text-body-info (.text body-info))
                (body-text (list-tail text-body-info test-length))
                (body-length (length (text->list body-text)))

                (text+test-text (.text (test-jump->info body-length)))
                (test-text (list-tail text+test-text text-length)))

           (clone info #:text
                  (append text
                          test-text
                          body-text)
                  #:globals (.globals body-info))))

        ((expr-stmt (cond-expr ,test ,then ,else))
         (let* ((text-length (length text))

                (test-jump->info ((test->jump->info info) test))
                (test+jump-info (test-jump->info 0))
                (test-length (length (.text test+jump-info)))

                (then-info ((ast->info test+jump-info) then))
                (text-then-info (.text then-info))
                (then-text (list-tail text-then-info test-length))
                (then-length (length (text->list then-text)))

                (jump-text (list (lambda (f g t d) (i386:jump 0))))
                (jump-length (length (text->list jump-text)))
                (test+then+jump-info
                 (clone then-info
                        #:text (append (.text then-info) jump-text)))

                (else-info ((ast->info test+then+jump-info) else))
                (text-else-info (.text else-info))
                (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
                (else-length (length (text->list else-text)))

                (text+test-text (.text (test-jump->info (+ then-length jump-length))))
                (test-text (list-tail text+test-text text-length))
                (jump-text (list (lambda (f g t d) (i386:jump else-length)))))

           (clone info #:text
                  (append text
                          test-text
                          then-text
                          jump-text
                          else-text)
                  #:globals (.globals else-info))))

        ((for ,init ,test ,step ,body)
         (let* ((info (clone info #:text '()))

                (info ((ast->info info) init))

                (init-text (.text info))
                (init-locals (.locals info))
                (info (clone info #:text '()))

                (body-info ((ast->info info) body))
                (body-text (.text body-info))
                (body-length (length (text->list body-text)))

                (step-info ((ast->info info) `(expr-stmt ,step)))
                (step-text (.text step-info))
                (step-length (length (text->list step-text)))

                (test-jump->info ((test->jump->info info) test))
                (test+jump-info (test-jump->info 0))
                (test-length (length (text->list (.text test+jump-info))))

                (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length step-length))))) ;; FIXME: 2

                (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length step-length test-length))))))
                (jump-length (length (text->list jump-text)))

                (test-text (.text (test-jump->info jump-length))))

           (clone info #:text
                  (append text
                          init-text
                          skip-body-text
                          body-text
                          step-text
                          test-text
                          jump-text)
                  #:globals (append globals (.globals body-info)) ;; FIXME
                  #:locals locals)))

        ((while ,test ,body)
         (let* ((info (clone info #:text '()))
                (body-info ((ast->info info) body))
                (body-text (.text body-info))
                (body-length (length (text->list body-text)))

                (test-jump->info ((test->jump->info info) test))
                (test+jump-info (test-jump->info 0))
                (test-length (length (text->list (.text test+jump-info))))


                (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length))))) ;; FIXME: 2

                (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length test-length))))))
                (jump-length (length (text->list jump-text)))

                (test-text (.text (test-jump->info jump-length))))

           (clone info #:text
                  (append text
                          skip-body-text
                          body-text
                          test-text
                          jump-text)
                  #:globals (.globals body-info))))

        ((labeled-stmt (ident ,label) ,statement)
         (let ((info (clone info #:text (append text (list label)))))
           ((ast->info info) statement)))

        ((goto (ident ,label))
         (let ((offset (length (text->list text))))
           (clone info #:text
                  (append text
                          (list (lambda (f g t d)
                                  (i386:jump (- (label-offset (.function info) label f) offset))))))))

        ((p-expr (ident ,name))
         (clone info #:text
                (append text
                        (list (lambda (f g t d)
                                (append
                                 (i386:local->accu (assoc-ref locals name))
                                 (i386:accu-zero?)))))))

        ((p-expr (fixed ,value))
         (let ((value (cstring->number value)))
          (clone info #:text
                 (append text
                         (list (lambda (f g t d)
                                 (append
                                  (i386:value->accu value)
                                  (i386:accu-zero?))))))))

        ((de-ref (p-expr (ident ,name)))
         (clone info #:text
                (append text
                        (list (lambda (f g t d)
                                (append
                                 (i386:local->accu (assoc-ref locals name))
                                 (i386:byte-mem->accu)))))))

        ((fctn-call . ,call)
         (let ((info ((ast->info info) `(expr-stmt ,o))))
           (clone info #:text
                  (append (.text info)
                          (list (lambda (f g t d)
                                  (i386:accu-zero?)))))))

        ;; FIXME
        ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
        ((post-inc (p-expr (ident ,name)))
         (clone info #:text
                (append text (list (lambda (f g t d)
                                     (append
                                      (i386:local->accu (assoc-ref locals name))
                                      (i386:local-add (assoc-ref locals name) 1)
                                      (i386:accu-zero?)))))))
        ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
        ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
        ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
        ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))

        ;; i++
        ((expr-stmt (post-inc (p-expr (ident ,name))))
         (clone info #:text
                (append text (list (lambda (f g t d)
                                     (i386:local-add (assoc-ref locals name) 1))))))

        ;; ++i
        ((expr-stmt (pre-inc (p-expr (ident ,name))))
         (clone info #:text
                (append text (list (lambda (f g t d)
                                     (append
                                      (i386:local-add (assoc-ref locals name) 1)
                                      (i386:local->accu (assoc-ref locals name))
                                      (i386:accu-zero?)))))))

        ;; i--
        ((expr-stmt (post-dec (p-expr (ident ,name))))
         (clone info #:text
                (append text (list (lambda (f g t d)
                                     (append
                                      (i386:local->accu (assoc-ref locals name))
                                      (i386:local-add (assoc-ref locals name) -1)
                                      (i386:accu-zero?)))))))

        ;; --i
        ((expr-stmt (pre-dec (p-expr (ident ,name))))
         (clone info #:text
                (append text (list (lambda (f g t d)
                                     (append
                                      (i386:local-add (assoc-ref locals name) -1)
                                      (i386:local->accu (assoc-ref locals name))
                                      (i386:accu-zero?)))))))

        ((not ,expr)
         (let* ((test-info ((ast->info info) expr)))
           (clone info #:text
                  (append (.text test-info)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:accu-not)
                                   (i386:accu-zero?)))))
                  #:globals (.globals test-info))))

        ((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
         (let ((b (cstring->number b)))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->accu b)
                                   (i386:sub-base))))))))

        ((eq (p-expr (ident ,a)) (p-expr (char ,b)))
         (let ((b (char->integer (car (string->list b)))))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->accu b)
                                   (i386:sub-base))))))))

        ((eq (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
         (let ((b (- (cstring->number b))))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append 
                                   (i386:value->accu b)
                                   (i386:sub-base))))))))

        ((eq (fctn-call . ,call) (p-expr (fixed ,b)))
         (let ((b (cstring->number b))
               (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
           (clone info #:text
                  (append text
                          (.text info)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->base b)
                                   (i386:sub-base))))))))

        ((eq (fctn-call . ,call) (p-expr (char ,b)))
         (let ((b (char->integer (car (string->list b))))
               (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
           (clone info #:text
                  (append text
                          (.text info)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->base b)
                                   (i386:sub-base))))))))

        ((cast (type-name (decl-spec-list (type-spec (void)))) _)
         info)

        ((eq (fctn-call . ,call) (p-expr (ident ,b)))
         (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
           (clone info #:text
                  (append text
                          (.text info)
                          ((ident->base info) b)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:sub-base))))))))

        ((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
           (clone info #:text
                  (append text
                          (list (lambda (f g t d)
                                  (append
                                   (i386:local->accu (assoc-ref locals a))
                                   (i386:byte-mem->base)
                                   (i386:local->accu (assoc-ref locals b))
                                   (i386:byte-mem->accu)
                                   (i386:byte-test-base)))))))

        ((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
         (let ((b (cstring->number b)))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append 
                                   (i386:value->accu b)
                                   (i386:sub-base))))))))

        ((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
         (let ((b (- (cstring->number b))))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append 
                                   (i386:value->accu b)
                                   (i386:sub-base))))))))        

        
        ((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
         (let ((b (cstring->number b)))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append 
                                   (i386:value->accu b)
                                   (i386:sub-base)
                                   (i386:xor-zf))))))))
        
        ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
         (let ((b (- (cstring->number b))))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->accu b)
                                   (i386:sub-base)
                                   (i386:xor-zf))))))))

        ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
         (let ((b (cstring->number b))
               (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
           (clone info #:text
                  (append text
                          (.text info)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->base b)
                                   (i386:sub-base)
                                   (i386:xor-zf))))))))

        ((ne (fctn-call . ,call) (p-expr (ident ,b)))
         (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
           (clone info #:text
                  (append text
                          (.text info)
                          ((ident->base info) b)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:sub-base)
                                   (i386:xor-zf))))))))

        ((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
           (clone info #:text
                  (append text
                          (list (lambda (f g t d)
                                  (append
                                   (i386:local->accu (assoc-ref locals a))
                                   (i386:byte-mem->base)
                                   (i386:local->accu (assoc-ref locals b))
                                   (i386:byte-mem->accu)
                                   (i386:byte-test-base)
                                   (i386:xor-zf)))))))

        ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
         (let ((b (cstring->number b)))
           (clone info #:text
                  (append text
                          ((ident->base info) a)
                          (list (lambda (f g t d)
                                  (append 
                                   (i386:value->accu b)
                                   (i386:base-sub))))))))

        ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
         (clone info #:text
                (append text
                        (list (lambda (f g t d)
                                (append
                                 (i386:local->accu (assoc-ref locals a))
                                 (i386:byte-mem->base)
                                 (i386:local->accu (assoc-ref locals b))
                                 (i386:byte-mem->accu)
                                 (i386:byte-sub-base)))))))

        ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
         (let ((value (cstring->number value)))
           (clone info #:text
                  (append text
                          ((ident->base info) name)
                          (list (lambda (f g t d)
                                       (append
                                        (i386:value->accu value)
                                        (i386:byte-base-mem->accu)))))))) ; FIXME: type: char
        
        ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
         (clone info #:text
                (append text
                        ((ident->base info) name)
                        ((ident->accu info) index)
                        (list (lambda (f g t d)
                                (i386:byte-base-mem->accu)))))) ; FIXME: type: char
        
        ((return ,expr)
         (let ((accu ((expr->accu info) expr)))
           (if (info? accu)
               (clone accu #:text
                      (append (.text accu) (list (i386:ret (lambda _ '())))))
               (clone info #:text
                      (append text (list (i386:ret accu)))))))

        ;; int i;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
         (clone info #:locals (add-local name)))

        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (let ((value (cstring->number value)))
             (clone info #:text
                    (append text ((value->ident info) name value))))))

        ;; int i = argc;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (clone info #:text
                  (append text
                          ((ident->accu info) local)
                          ((accu->ident info) name)))))

        ;; char *p = "t.c";
        ;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n"))))))
        ((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
         (let* ((locals (add-local name))
                (globals (append globals (list (string->global value))))
                (info (clone info #:locals locals #:globals globals)))
           (clone info #:text
                  (append text
                          (list (lambda (f g t d)
                                  (append
                                   (i386:global->accu (+ (data-offset value g) d)))))
                          ((accu->ident info) name)))))
        
        ;; SCM g_stack = 0;
        ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
         ((ast->info info) (list-head o (- (length o) 1))))

        ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
         (if (.function info)
             (let* ((locals (add-local name))
                    (globals (append globals (list (string->global value))))
                    (info (clone info #:locals locals #:globals globals)))
               (clone info #:text
                      (append text
                              (list (lambda (f g t d)
                                      (append
                                       (i386:global->accu (+ (data-offset value g) d)))))
                              ((accu->ident info) name))))
             (let* ((value (length (globals->data globals)))
                    (globals (append globals (list (ident->global name value)))))
               (clone info #:globals globals))))

        ;; SCM i = argc;
        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
         (let* ((locals (add-local name))
               (info (clone info #:locals locals)))
           (clone info #:text
                  (append text
                          ((ident->accu info) local)
                          ((accu->ident info) name)))))
        
        ;; int i = f ();
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
             (clone info
                    #:text
                    (append (.text info)
                            ((accu->ident info) name))
                    #:locals locals))))
        
        ;; SCM x = car (e);
        ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
             (clone info
                    #:text
                    (append (.text info)
                            ((accu->ident info) name))))))

        ;; i = 0;
        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
         ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
         (let ((value (cstring->number value)))
           (clone info #:text (append text ((value->ident info) name value)))))

        ;; i = 0; ...from for init FIXME
        ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
         (let ((value (cstring->number value)))
           (clone info #:text (append text ((value->ident info) name value)))))

        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
         (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
           (clone info #:text (append (.text info) ((accu->ident info) name)))))

        (_
         (format (current-error-port) "SKIP statement=~s\n" o)
         info)))))

(define (info->exe info)
  (display "dumping elf\n" (current-error-port))
  (map write-any (make-elf (.functions info) (.globals info))))

(define (.formals o)
  (pmatch o
    ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
    (_ (format (current-error-port) ".formals: no match: ~a\n" o)
       barf)))

(define (formal->text n)
  (lambda (o i)
    ;;(i386:formal i n)
    '()
    ))

(define (formals->text o)
  (pmatch o
    ((param-list . ,formals)
     (let ((n (length formals)))
       (list (lambda (f g t d)
               (append
                (i386:function-preamble)
                (append-map (formal->text n) formals (iota n))
                (i386:function-locals))))))
    (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
       barf)))

(define (formals->locals o)
  (pmatch o
    ((param-list . ,formals)
     (let ((n (length formals)))
       ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
       (map cons (map .name formals) (iota n -2 -1))))
    (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
       barf)))

(define (function->info info)
  (lambda (o)
    ;;(stderr "\n")
    ;;(stderr "formals=~a\n" (.formals o))
    (let* ((name (.name o))
           (text (formals->text (.formals o)))
           (locals (formals->locals (.formals o))))
      (format (current-error-port) "compiling ~a\n" name)
      ;;(stderr "locals=~a\n" locals)
      (let loop ((statements (.statements o))
                 (info (clone info #:locals locals #:function name #:text text)))
        (if (null? statements) (clone info
                                      #:function #f
                                      #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
            (let* ((statement (car statements)))
              (loop (cdr statements)
                    ((ast->info info) (car statements)))))))))

(define (ast-list->info info)
  (lambda (elements)
    (let loop ((elements elements) (info info))
      (if (null? elements) info
          (loop (cdr elements) ((ast->info info) (car elements)))))))

(define _start
  (let* ((argc-argv
          (string-append ".byte"
                         " 0x89 0xe8"      ; mov    %ebp,%eax
                         " 0x83 0xc0 0x08" ; add    $0x8,%eax
                         " 0x50"           ; push   %eax
                         " 0x89 0xe8"      ; mov    %ebp,%eax
                         " 0x83 0xc0 0x04" ; add    $0x4,%eax
                         " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
                         " 0x50"           ; push   %eax
                         ))
         (ast (with-input-from-string
                  
                  (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
                parse-c99)))
    ast))

(define strlen
  (let* ((ast (with-input-from-string
                  "
int
strlen (char const* s)
{
  int i = 0;
  while (s[i]) i++;
  return i;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define getchar
  (let* ((ast (with-input-from-string
                  "
int
getchar ()
{
  char c;
  int r = read (g_stdin, &c, 1);
  //int r = read (0, &c, 1);
  if (r < 1) return -1;
  return c;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define putchar
  (let* ((ast (with-input-from-string
                  "
int
putchar (int c)
{
  //write (STDOUT, s, strlen (s));
  //int i = write (STDOUT, s, strlen (s));
  write (1, (char*)&c, 1);
  return 0;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define eputs
  (let* ((ast (with-input-from-string
                  "
int
eputs (char const* s)
{
  //write (STDERR, s, strlen (s));
  //write (2, s, strlen (s));
  int i = strlen (s);
  write (2, s, i);
  return 0;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define fputs
  (let* ((ast (with-input-from-string
                  "
int
fputs (char const* s, int fd)
{
  int i = strlen (s);
  write (fd, s, i);
  return 0;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define puts
  (let* ((ast (with-input-from-string
                  "
int
puts (char const* s)
{
  //write (STDOUT, s, strlen (s));
  //int i = write (STDOUT, s, strlen (s));
  int i = strlen (s);
  write (1, s, i);
  return 0;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define strcmp
  (let* ((ast (with-input-from-string
                  "
int
strcmp (char const* a, char const* b)
{
  while (*a && *b && *a == *b) 
    {
      a++;b++;
    }
  return *a - *b;
}
"
;;paredit:"
                parse-c99)))
    ast))

(define i386:libc
  (list
   (cons "exit" (list i386:exit))
   (cons "open" (list i386:open))
   (cons "read" (list i386:read))
   (cons "write" (list i386:write))))

(define libc
  (list
   strlen
   getchar
   putchar
   eputs
   fputs
   puts
   strcmp))

(define (compile)
  (let* ((ast (mescc))
         (info (make <info> #:functions i386:libc))
         (info ((ast->info info) libc))
         (info ((ast->info info) ast))
         (info ((ast->info info) _start)))
    (info->exe info)))