mes/module/language/c99/compiler.mes

;;; -*-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 <types> '<types>)
(define <constants> '<constants>)
(define <functions> '<functions>)
(define <globals> '<globals>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)

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

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

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

(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 ((types (.types o))
               (constants (.constants o))
               (functions (.functions o))
               (globals (.globals o))
               (locals (.locals o))
               (function (.function o))
               (text (.text o)))
           (let-keywords rest
                         #f
                         ((types types)
                          (constants constants)
                          (functions functions)
                          (globals globals)
                          (locals locals)
                          (function function)
                          (text text))
                         (make <info> #:types types #:constants constants #: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-global-de-ref push-global)

(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 (push-ident-de-ref globals locals)
  (lambda (o)
    (let ((local (assoc-ref locals o)))
      (if local (i386:push-local-de-ref local)
          ((push-global-de-ref globals) o)))))

(define (expr->arg info) ;; FIXME: get Mes curried-definitions
  (lambda (o)
    (pmatch o
      ((p-expr (fixed ,value)) (cstring->number value))
      ((neg (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-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
       (let ((value (cstring->number value))
             (size 4)) ;; FIXME: type: int
         (append
          ((ident->base (.locals info)) name)
          (list
           (lambda (f g t d)
             (append
              (i386:value->accu (* size value)) ;; FIXME: type: int
              (i386:base-mem->accu)             ;; FIXME: type: int
              (i386:push-accu)                  ;; hmm
              ))))))

      ((de-ref (p-expr (ident ,name)))
       (lambda (f g t d)
         ((push-ident-de-ref (.globals info) (.locals info)) name)))

      ((ref-to (p-expr (ident ,name)))
       (lambda (f g t d)
         ((push-ident-ref (.globals info) (.locals info)) name)))

      ;; f (car (x))
      ((fctn-call . ,call)
       (let ((info ((ast->info info) o)))
         (append (.text info)
                 (list
                  (lambda (f g t d)
                    (i386:push-accu))))))

      ;; f (CAR (x))
      ((d-sel . ,d-sel)
       (let* ((empty (clone info #:text '()))
              (expr ((expr->accu empty) `(d-sel ,@d-sel))))
         (append (.text expr)
                 (list (lambda (f g t d)
                         (i386:push-accu))))))

      ;; f (0 + x)
      ;;; aargh
      ;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))

      ((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=~s\n" o)     
       0))))

(define (ident->accu info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local
          (list (lambda (f g t d)
                  (if (equal? o "c1")
                      (i386:byte-local->accu local) ;; FIXME
                      (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)))

      ;; g_cells[10].type
      ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
       (let* ((struct-type "scm") ;; FIXME
              (struct (assoc-ref (.types info) struct-type))
              (size (length struct))
              (field-size 4) ;; FIXME:4, not fixed
              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
              (index (cstring->number index))
              (text (.text info)))
         (clone info #:text
                (append text
                        (list (lambda (f g t d)
                                (append
                                 (i386:value->base index)
                                 (i386:base->accu)
                                 (if (> size 1) (i386:accu+accu) '())
                                 (if (= size 3) (i386:accu+base) '())
                                 (i386:accu-shl 2)
                                 ;;;'(#x58 #x58)
                                 )))
                        ((ident->base info) array)
                        (list (lambda (f g t d)
                                (i386:accu+base)))))))

      ;; g_cells[x].type
      ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
       (let* ((struct-type "scm") ;; FIXME
              (struct (assoc-ref (.types info) struct-type))
              (size (length struct))
              (field-size 4) ;; FIXME:4, not fixed
              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
              (text (.text info)))
         (clone info #:text
                (append text
                        ((ident->base info) index)
                        (list (lambda (f g t d)
                                (append
                                 (i386:base->accu)
                                 (if (> size 1) (i386:accu+accu) '())
                                 (if (= size 3) (i386:accu+base) '())
                                 (i386:accu-shl 2))))
                        ((ident->base info) array)
                        (list (lambda (f g t d)
                                (i386:base-mem+n->accu offset)
                                ;;(i386:accu+base)
                                ))))))

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

(define (expr->Xaccu info)
  (lambda (o)
    (pmatch o
      ;; g_cells[10].type
      ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
       (let* ((struct-type "scm") ;; FIXME
              (struct (assoc-ref (.types info) struct-type))
              (size (length struct))
              (field-size 4) ;; FIXME:4, not fixed
              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
              (index (cstring->number index))
              (text (.text info)))
         (clone info #:text
                (append text
                        (list (lambda (f g t d)
                                (append
                                 (i386:value->base index)
                                 (i386:base->accu)
                                 (if (> size 1) (i386:accu+accu) '())
                                 (if (= size 3) (i386:accu+base) '())
                                 (i386:accu-shl 2))))
                        ((ident->base info) array)
                        (list (lambda (f g t d)
                                (i386:accu+base)))))))

      ;; g_cells[x].type
      ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
       (let* ((struct-type "scm") ;; FIXME
              (struct (assoc-ref (.types info) struct-type))
              (size (length struct))
              (field-size 4) ;; FIXME:4, not fixed
              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
              (text (.text info)))
         (clone info #:text
                (append text
                        ((ident->base info) index)
                        (list (lambda (f g t d)
                                (append
                                 (i386:base->accu)
                                 (if (> size 1) (i386:accu+accu) '())
                                 (if (= size 3) (i386:accu+base) '())
                                 (i386:accu-shl 2))))
                        ((ident->base info) array)
                        (list (lambda (f g t d)
                                (i386:accu+base)))))))

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

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

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

(define (ident->constant name value)
  (cons name value))

(define (ident->type name value)
  (cons name 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:~s\n" o)'())
        (let ((s (string-drop o (string-length prefix))))
          (map byte->hex (string-split s #\space))))))

(define (case->jump-info info)
  (define (jump n)
    (list (lambda (f g t d) (i386:Xjump n))))
  (define (jump-nz n)
    (list (lambda (f g t d) (i386:Xjump-nz n))))
  (define (statement->info info body-length)
    (lambda (o)
      (pmatch o
        ((break) (clone info #:text (append (.text info) (jump body-length)
)))
        (_
         ((ast->info info) o)))))
  (lambda (o)
    (pmatch o
      ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
       (lambda (body-length)
         (let* ((value (assoc-ref (.constants info) constant))
                (text-length (length (.text info)))
                (clause-info (let loop ((elements elements) (info info))
                               (if (null? elements) info
                                   (loop (cdr elements) ((statement->info info body-length) (car elements))))))
                (clause-text (list-tail (.text clause-info) text-length))
                (clause-length (length (text->list clause-text))))
           (stderr "clause text[~a]: ~a\n" clause-length (map dec->hex (text->list clause-text)))
           (clone info #:text (append
                               (.text info)
                               (list (lambda (f g t d) (i386:accu-cmp-value value)))
                               (jump-nz clause-length)
                               clause-text)
                  #:globals (.globals clause-info)))))

      ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
       (lambda (body-length)
         (let* ((value (cstring->number value))
                (text-length (length (.text info)))
                (clause-info (let loop ((elements elements) (info info))
                               (if (null? elements) info
                                   (loop (cdr elements) ((statement->info info body-length) (car elements))))))
                (clause-text (list-tail (.text clause-info) text-length))
                (clause-length (length (text->list clause-text))))
           (stderr "clause text[~a]: ~a\n" clause-length (map dec->hex (text->list clause-text)))
           (clone info #:text (append
                               (.text info)
                               (list (lambda (f g t d) (i386:accu-cmp-value value)))
                               (jump-nz clause-length)
                               clause-text)
                  #:globals (.globals clause-info)))))

      ((default (compd-stmt (block-item-list . ,elements)))
       (lambda (body-length)
         (let ((text-length (length (.text info))))
          (let loop ((elements elements) (info info))
            (if (null? elements) (let ((clause-text (list-tail (.text info) text-length)))
                                   (stderr "default text[~a]: ~a\n" (length (text->list clause-text)) (map dec->hex (text->list clause-text)))
                                   info)
                (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
      (_ (stderr "no case match: ~a\n" o) barf)
      )))

(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)
  (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
        ((string-prefix? "0" s) (string->number s 8))
        (else (string->number s))))

(define (struct-field o)
  (pmatch o
    ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
                (comp-declr-list (comp-declr (ident ,name))))
     (cons type name))
    ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
     (cons type name))
    ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
     (cons type name))
    (_ (stderr "struct-field: no match: ~a" o) barf)))

(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))))

        ((switch ,expr (compd-stmt (block-item-list . ,cases)))
         (let* ((accu ((expr->accu info) expr))
                (expr (if (info? accu) accu ;; AAARGH
                          (clone info #:text
                                 (append text (list accu)))))
                (empty (clone info #:text '()))
                (case-infos (map (case->jump-info empty) cases))
                (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
                (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
                              (if (null? cases) info
                                  (let ((c-j ((case->jump-info info) (car cases))))
                                    (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
           cases-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)) (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)
                                   (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 (p-expr (ident ,a)) (p-expr (ident ,constant)))
         (let ((b (assoc-ref (.constants info) constant)))
           (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)))))))

        ((ne (de-ref (p-expr (ident ,a))) (p-expr (char ,b)))
         (let ((b (char->integer (car (string->list 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:value->accu b)
                                   (i386:byte-test-base)
                                   (i386:xor-zf))))))))

        ;; CAR (x) != 1 // cell_nil
        ((ne (d-sel . ,d-sel) (p-expr (fixed ,b)))
         (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
               (b (cstring->number b)))
           (clone info #:text
                  (append text
                          (.text expr)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->base b)
                                   (i386:sub-base)
                                   (i386:xor-zf))))))))

        ;; CAR (x) != PAIR
        ((ne (d-sel . ,d-sel) (p-expr (ident ,constant)))
         (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
               (b (assoc-ref (.constants info) constant)))
           (clone info #:text
                  (append text
                          (.text expr)
                          (list (lambda (f g t d)
                                  (append
                                   (i386:value->base b)
                                   (i386:sub-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 = 0;
        ((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))
                (value (cstring->number value)))
           (clone info #:text
                  (append text
                          ((value->ident info) name value)))))

        ;; int i = -1;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals))
                (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)))))
        
        ;; char arena[20000];
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
         (let* ((globals (.globals info))
                (count (cstring->number count))
                (size 1) ;; FIXME
                (array (list (ident->global name 0)))  ;;FIXME: deref?
                (dummy (list (cons (string->list "dummy")
                                   (string->list (make-string (* count size) #\nul))))))
           (clone info #:globals (append globals array dummy))))

        ;;struct scm *g_cells = (struct scm*)arena;
        ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (clone info #:text
                  (append text
                          ((ident->accu info) name)
                          ((accu->ident info) value))))) ;; FIXME: deref?

        ;; 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))))))

        ;; char *p = (char*)g_cells;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (clone info #:text
                  (append text
                          ((ident->accu info) value)
                          ((accu->ident info) name)))))

        ;; char *p = g_cells;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
         (let* ((locals (add-local name))
                (info (clone info #:locals locals)))
           (clone info #:text
                  (append text
                          ((ident->accu info) value)
                          ((accu->ident info) name)))))

        ;; enum 
        ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
         (let ((type (ident->type name "enum"))
               (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
           (clone info #:types (append (.types info) (list type))
                  #:constants (append constants (.constants info)))))

        ;; struct
        ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
         (let* ((type (ident->type name (map struct-field fields))))
           (clone info #:types (append (.types info) (list type)))))
        
        ;; 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)))))

        ;; p = g_cell;
        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (ident ,value))))
         (clone info #:text
                (append text
                        ((ident->accu info) value)
                        ((accu->ident info) name))))
        
        ;; *p++ = c;
        ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op _) (p-expr (ident ,value))))
         (let* ((locals (add-local name))
               (info (clone info #:locals locals)))
           (clone info #:text
                  (append text
                          ((ident->accu info) value)
                          ((accu->ident info) name)
                          (list (lambda (f g t d)
                                  (i386:local-add (assoc-ref locals name) 1)))))))

        ((d-sel . ,d-sel)
         (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
           expr))        

        ;; i = CAR (x)
        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (d-sel . ,d-sel)))
         (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
           (clone info #:text (append (.text expr)
                                      ((accu->ident info) name)))))


        ;; TYPE (x) = PAIR;
        ;; ((expr-stmt (assn-expr (d-sel . ,d-sel) (op _) (p-expr (ident ,constant))))
        ;;  (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
        ;;        (b (assoc-ref (.constants info) constant)))
        ;;    (clone info #:text (append (.text expr)
        ;;                               (list (lambda (f g t d)
        ;;                                       (i386:accu+base)
        ;;                                       (i386:value->accu-ref b)))))))

        ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (ident ,constant))))
         (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
                (b (assoc-ref (.constants info) constant))

                (struct-type "scm") ;; FIXME
                (struct (assoc-ref (.types info) struct-type))
                (size (length struct))
                (field-size 4) ;; FIXME:4, not fixed
                (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))))
           (clone info #:text (append (.text expr)
                                      (list (lambda (f g t d)
                                              (i386:value->accu-ref+n offset b)))))))

        ;; CAR (x) = 0
        ;; ((expr-stmt (assn-expr (d-sel . ,d-sel) (op _) (p-expr (fixed ,value))))
        ;;  (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
        ;;        (b (cstring->number value)))
        ;;    (clone info #:text (append (.text expr)
        ;;                               (list (lambda (f g t d)
        ;;                                       (i386:accu+base)
        ;;                                       (i386:value->accu-ref b)))))))
        ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (fixed ,value))))
         (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
                (b (cstring->number value))
                
                (struct-type "scm") ;; FIXME
                (struct (assoc-ref (.types info) struct-type))
                (size (length struct))
                (field-size 4) ;; FIXME:4, not fixed
                (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))               )
           (clone info #:text (append (.text expr)
                                      (list (lambda (f g t d)
                                              (i386:value->accu-ref+n offset b)))))))

        ;; g_cells[0] = 65;
        ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
         (let ((index (cstring->number index))
               (value (cstring->number value)))
          (clone info #:text
                 (append text
                         ((ident->base info) name)
                         ((ident->accu info) index)
                         (list (lambda (f g t d)
                                 (i386:accu+base)
                                 (i386:value->accu-ref value)))))))

        ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (char ,value))))
         (let ((index (cstring->number index))
               (value (char->integer (car (string->list value)))))
          (clone info #:text
                 (append text
                         ((ident->base info) name)
                         ((ident->accu info) index)
                         (list (lambda (f g t d)
                                 (i386:accu+base)
                                 (i386:value->accu-ref value)))))))

        (_
         (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 c1;
  int r = read (g_stdin, &c1, 1);
  //int r = read (0, &c1, 1);
  if (r < 1) return -1;
  return c1;
}
"
;;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))
         (ast (append libc ast))
         (info ((ast->info info) ast))
         (info ((ast->info info) _start)))
    (info->exe info)))