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 (mes pmatch))
  (mes-use-module (nyacc lang c99 parser))
  (mes-use-module (mes elf-util))
  (mes-use-module (mes elf))
  (mes-use-module (mes as-i386))
  (mes-use-module (mes libc))
  (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 (mescc)
  (parse-c99
   #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
   #:cpp-defs `(
                "_POSIX_SOURCE=0"
                "__GNUC__=0"
                "__MESC__=1"
                "__NYACC__=1" ;; REMOVEME
                "STDIN=0"
                "STDOUT=1"
                "STDERR=2"
                "O_RDONLY=0"

                "INT_MIN=-2147483648"
                "INT_MAX=2147483647"

                ,(string-append "DATADIR=\"" %datadir "\"")
                ,(string-append "DOCDIR=\"" %docdir "\"")
                ,(string-append "PREFIX=\"" %prefix "\"")
                ,(string-append "MODULEDIR=\"" %moduledir "\"")
                ,(string-append "VERSION=\"" %version "\"")
                )
   #: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 ==> ~a\n" x (dec->hex 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 (.type o)
  (pmatch o
    ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
    ((param-decl ,type _) type)
    (_
     (format (current-error-port) "SKIP: .type =~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 <init> '<init>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
(define <break> '<break>)

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

(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 (.init o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <init>))))

(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 (.break o)
  (pmatch o
    ((<info> . ,alist) (assq-ref alist <break>))))

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

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

(define (push-local locals)
  (lambda (o)
    (wrap-as (i386:push-local (local:id o)))))

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

(define (push-local-address locals)
  (lambda (o)
    (wrap-as (i386:push-local-address (local:id o)))))

(define push-global-de-ref push-global)

(define (push-local-de-ref locals)
  (lambda (o)
    (wrap-as (i386:push-local-de-ref (local:id o)))))

(define (string->global string)
  (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))

(define (ident->global name type pointer value)
  (make-global name type pointer (int->bv32 value)))

(define (make-local name type pointer id)
  (cons name (list type pointer id)))
(define local:type car)
(define local:pointer cadr)
(define local:id caddr)

(define (push-ident info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local ((push-local (.locals info)) local)
          (let ((global (assoc-ref (.globals info) o)))
            (if global
                ((push-global (.globals info)) o) ;; FIXME: char*/int
                (let ((constant (assoc-ref (.constants info) o)))
                  (if constant
                      (wrap-as (append (i386:value->accu constant)
                                       (i386:push-accu)))
                      TODO:push-function))))))))

(define (push-ident-address info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local ((push-local-address (.locals info)) local)
          ((push-global-address (.globals info)) o)))))

(define (push-ident-de-ref info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local ((push-local-de-ref (.locals info)) local)
          ((push-global-de-ref (.globals info)) o)))))

(define (expr->arg info)
  (lambda (o)
    (let ((info ((expr->accu info) o)))
      (append-text info (wrap-as (i386:push-accu))))))

(define (expr->arg info) ;; FIXME: get Mes curried-definitions
  (lambda (o)
    (let ((text (.text info)))
      ;;(stderr  "expr->arg o=~s\n" o)
      (pmatch o

        ((p-expr (string ,string))
         (append-text info ((push-global-address info) (add-s:-prefix string))))

        ((p-expr (ident ,name))
         (append-text info ((push-ident info) name)))

        ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
                          (abs-declr (pointer)))
               ,cast)
         ((expr->arg info) cast))

        ((de-ref (p-expr (ident ,name)))
         (append-text info ((push-ident-de-ref info) name)))

        ((ref-to (p-expr (ident ,name)))
         (append-text info ((push-ident-address info) name)))

        (_ (append-text ((expr->accu info) o)
                        (wrap-as (i386:push-accu))))))))

;; FIXME: see ident->base
(define (ident->accu info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o))
          (global (assoc-ref (.globals info) o))
          (constant (assoc-ref (.constants info) o)))
      ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
      ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
      ;; (stderr "globals: ~a\n" (.globals info))
      ;; (if (and (not global) (not (local:id local)))
      ;;     (stderr "globals: ~a\n" (map car (.globals info))))
      (if local
          (let* ((ptr (local:pointer local))
                 (type (ident->type info o))
                 (size (and type (type->size info type))))
            ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
            ;;(stderr "type: ~s\n" type)
            ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
            ;;(stderr "locals: ~s\n" locals)
            (case ptr
              ((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
              ((1) (wrap-as (i386:local->accu (local:id local))))
              (else
               (wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
                            (i386:local->accu (local:id local)))))))
          (if global
              (let ((ptr (ident->pointer info o)))
                ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
                (case ptr
                  ((-1) (list (lambda (f g ta t d)
                                (i386:global->accu (+ (data-offset o g) d)))))
                  (else (list (lambda (f g ta t d)
                                (i386:global-address->accu (+ (data-offset o g) d)))))))
              (if constant (wrap-as (i386:value->accu constant))
                  (list (lambda (f g ta t d)
                          (i386:global->accu (+ ta (function-offset o f)))))))))))

(define (value->accu v)
  (wrap-as (i386:value->accu v)))

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

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

(define (base->ident-address info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      (if local (wrap-as (append (i386:local->accu (local:id local))
                                 (i386:byte-base->accu-address)))
          TODO:base->ident-address-global))))

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

(define (ident-add info)
  (lambda (o n)
    (let ((local (assoc-ref (.locals info) o)))
      (if local (wrap-as (i386:local-add (local:id local) n))
          (list (lambda (f g ta t d)
                  (i386:global-add (+ (data-offset o g) d) n)))))))

;; FIXME: see ident->accu
(define (ident->base info)
  (lambda (o)
    (let ((local (assoc-ref (.locals info) o)))
      ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
      (if local
          (let* ((ptr (local:pointer local))
                 (type (ident->type info o))
                 (size (and type (type->size info type))))
            (case ptr
              ((-1) (wrap-as (i386:local-ptr->base (local:id local))))
              ((1) (wrap-as (i386:local->base (local:id local))))
              (else
               (wrap-as (if (= size 1) (i386:byte-local->base (local:id local))
                            (i386:local->base (local:id local)))))))
          (let ((global (assoc-ref (.globals info) o) ))
            (if global
                (let ((ptr (ident->pointer info o)))
                  ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
                  (case ptr
                    ((-1) (list (lambda (f g ta t d)
                                  (i386:global->base (+ (data-offset o g) d)))))
                    (else (list (lambda (f g ta t d)
                                  (i386:global-address->base (+ (data-offset o g) d)))))))
                (let ((constant (assoc-ref (.constants info) o)))
                  (if constant (wrap-as (i386:value->base constant))
                      (list (lambda (f g ta t d)
                              (i386:global->base (+ ta (function-offset o f)))))))))))))

(define (expr->accu info)
  (lambda (o)
    (let ((locals (.locals info))
          (constants (.constants info))
          (text (.text info))
          (globals (.globals info)))
      (define (add-local locals name type pointer)
        (let* ((id (1+ (length (filter local? (map cdr locals)))))
               (locals (cons (make-local name type pointer id) locals)))
          locals))
      ;; (stderr "expr->accu o=~a\n" o)
      (pmatch o
        ((p-expr (string ,string))
         (append-text info (list (lambda (f g ta t d)
                                   (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))
        ((p-expr (fixed ,value))
         (append-text info (value->accu (cstring->number value))))
        ((p-expr (ident ,name))
         (append-text info ((ident->accu info) name)))

        ((initzer ,initzer) ((expr->accu info) initzer))
        ((ref-to (p-expr (ident ,name)))
         (append-text info ((ident->accu info) name)))

        ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
         (let* ((type (list "struct" name))
                (fields (or (type->description info type) '()))
                (size (type->size info type)))
           (append-text info (wrap-as (i386:value->accu size)))))
        
        ;; c+p expr->arg
        ;; g_cells[<expr>]
        ((array-ref ,index (p-expr (ident ,array)))
         (let* ((type (ident->type info array))
                (size (type->size info type))
                (info ((expr->accu* info) o)))
           (append-text info (wrap-as (append (case size
                                                ((1) (i386:byte-mem->accu))
                                                ((4) (i386:mem->accu))
                                                (else '())))))))

        ;; f.field
        ((d-sel (ident ,field) (p-expr (ident ,array)))
         (let* ((type (ident->type info array))
                (fields (type->description info type))
                (field-size 4) ;; FIXME:4, not fixed
                (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
                (text (.text info)))
           (append-text info (append ((ident->accu info) array)
                                     (wrap-as (i386:mem+n->accu offset))))))

        ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
         (let* ((type (ident->type info array))
                (fields (or (type->description info type) '()))
                (field-size 4) ;; FIXME:4, not fixed
                (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
                          (begin
                            (stderr "no field:~a\n" field)
                            '())))
                (offset (* field-size (1- (length rest))))
                (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
           (append-text info (wrap-as (i386:mem+n->accu offset)))))

        ;;; FIXME: FROM INFO ...only zero?!
        ((p-expr (fixed ,value))
         (let ((value (cstring->number value)))
           (append-text info (wrap-as (i386:value->accu value)))))

        ((p-expr (char ,char))
         (let ((char (char->integer (car (string->list char)))))
           (append-text info (wrap-as (i386:value->accu char)))))

        ((p-expr (ident ,name))
         (append-text info ((ident->accu info) name)))

        ((de-ref (p-expr (ident ,name)))
         (let* ((type (ident->type info name))
                (size (and type (type->size info type))))
           (append-text info (append ((ident->accu info) name)
                                     (wrap-as (if (= size 1) (i386:byte-mem->accu)
                                                  (i386:mem->accu)))))))

        ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
         (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
                                   (append-text info (wrap-as (asm->hex arg0))))
             (let* ((globals (append globals (filter-map expr->global expr-list)))
                    (info (clone info #:globals globals))
                    (text-length (length text))
                    (args-info (let loop ((expressions (reverse expr-list)) (info info))
                                 (if (null? expressions) info
                                     (loop (cdr expressions) ((expr->arg info) (car expressions))))))
                    (text (.text args-info))
                    (n (length expr-list)))
               (if (and (not (assoc-ref locals name))
                        (assoc-ref (.functions info) name))
                   (clone args-info #:text
                          (append text
                                  (list (lambda (f g ta t d)
                                          (i386:call f g ta t d (+ t (function-offset name f)) n))))
                          #:globals globals)
                   (let* ((empty (clone info #:text '()))
                          (accu ((expr->accu empty) `(p-expr (ident ,name)))))
                     (clone args-info #:text
                            (append text
                                    (.text accu)
                                    (list (lambda (f g ta t d)
                                            (i386:call-accu f g ta t d n))))
                            #:globals globals))))))

        ((fctn-call ,function (expr-list . ,expr-list))
         (let* ((globals (append globals (filter-map expr->global expr-list)))
                (info (clone info #:globals globals))
                (text-length (length text))
                (args-info (let loop ((expressions (reverse expr-list)) (info info))
                             (if (null? expressions) info
                                 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
                (text (.text args-info))
                (n (length expr-list))
                (empty (clone info #:text '()))
                (accu ((expr->accu empty) function)))
           (clone info #:text
                  (append text
                          (.text accu)
                          (list (lambda (f g ta t d)
                                  (i386:call-accu f g ta t d n))))
                  #:globals globals)))

        ((cond-expr . ,cond-expr)
         ((ast->info info) `(expr-stmt ,o)))

        ((post-inc (p-expr (ident ,name)))
         (append-text info (append ((ident->accu info) name)
                                   ((ident-add info) name 1))))

        ((post-dec (p-expr (ident ,name)))
         (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
         (append-text info (append ((ident->accu info) name)
                                   ((ident-add info) name -1))))

        ((pre-inc (p-expr (ident ,name)))
         (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
         (append-text info (append ((ident-add info) name 1)
                                   ((ident->accu info) name))))

        ((pre-dec (p-expr (ident ,name)))
         (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
         (append-text info (append ((ident-add info) name -1)
                                   ((ident->accu info) name))))

        ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
        ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
        ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
        ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
        ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
        ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
        ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
        ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))

        ((not ,expr)
         (let* ((test-info ((ast->info info) expr)))
           (clone info #:text
                  (append (.text test-info)
                          (wrap-as (i386:accu-not)))
                  #:globals (.globals test-info))))

        ((neg (p-expr (fixed ,value)))
         (append-text info (value->accu (- (cstring->number value)))))

        ((neg (p-expr (ident ,name)))
         (append-text info (append ((ident->base info) name)
                                   (wrap-as (i386:value->accu 0))
                                   (wrap-as (i386:sub-base)))))

        ((eq ,a ,b) ((binop->accu info) a b (i386:sub-base)))
        ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
        ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
        ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base)
                                                    (i386:xor-zf))))
        ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
        ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))

        ((cast ,cast ,o)
         ((expr->accu info) o))

        ((assn-expr ,a (op ,op) ,b)
         (let* ((info ((expr->accu info) b))
                (info (if (equal? op "=") info
                          (let* ((info (append-text info (wrap-as (i386:push-accu))))
                                 (info ((expr->accu info) a))
                                 (info (append-text info (wrap-as (i386:pop-base)))))
                            (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
                                                    ((equal? op "-=") (wrap-as (i386:accu-base)))
                                                    ((equal? op "*=") (wrap-as (i386:accu*base)))
                                                    ((equal? op "/=") (wrap-as (i386:accu/base)))
                                                    ((equal? op "%=") (wrap-as (i386:accu%base)))
                                                    ((equal? op "|=") (wrap-as (i386:accu-or-base)))
                                                    (else (error "mescc: op ~a not supported: ~a\n" op o))))))))
           (pmatch a
             ((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
             ((d-sel (ident ,field) . ,d-sel)
              (let* ((type (list "struct" "scm")) ;; FIXME
                     (fields (type->description info type))
                     (size (type->size info type))
                     (field-size 4) ;; FIXME:4, not fixed
                     (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                
                     (info (append-text info (wrap-as (i386:push-accu))))
                     (info ((expr->accu* info) a))
                     (info (append-text info (wrap-as (i386:pop-base)))))
                (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
             ((de-ref (p-expr (ident ,array)))
              (append-text info (append (wrap-as (i386:accu->base))
                                        ((base->ident-address info) array)
                                        (wrap-as (i386:base->accu)))))
             ((de-ref (post-inc (p-expr (ident ,name))))
              (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
                (append-text info ((ident-add info) name 1))))
             ((de-ref (post-dec (p-expr (ident ,name))))
              (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
                (append-text info ((ident-add info) name -1))))
             ((array-ref ,index (p-expr (ident ,array)))
              (let* ((type (ident->type info array))
                     (size (type->size info type))
                     (info (append-text info (wrap-as (append (i386:push-accu)))))
                     (info ((expr->accu* info) a))
                     (info (append-text info (wrap-as (append (i386:pop-base))))))
                (append-text info
                             (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
                                         (append
                                          (wrap-as (i386:base-address->accu-address))
                                          (if (<= size 4) '()
                                              (wrap-as (append (i386:accu+n 4)
                                                               (i386:base+n 4)
                                                               (i386:base-address->accu-address))))
                                          (if (<= size 8) '()
                                              (wrap-as (append (i386:accu+n 4)
                                                               (i386:base+n 4)
                                                               (i386:base-address->accu-address))))))))))
             (_ barf-assign))))

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

(define (expr->base info)
  (lambda (o)
    (let* ((info (append-text info (wrap-as (i386:push-accu))))
           (info ((expr->accu info) o))
           (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
      info)))

(define (binop->accu info)
  (lambda (a b c)
    (let* ((info ((expr->accu info) a))
           (info ((expr->base info) b)))
      (append-text info (wrap-as c)))))

(define (append-text info text)
  (clone info #:text (append (.text info) text)))

(define (wrap-as o)
  (list (lambda (f g ta t d) o)))

(define (expr->accu* info)
  (lambda (o)
    ;; (stderr "expr->accu* o=~s\n" o)

    (pmatch o
      ;; g_cells[<expr>]
      ((array-ref ,index (p-expr (ident ,array)))
       (let* ((info ((expr->accu info) index))
              (type (ident->type info array))
              (size (type->size info type)))
         (append-text info (append (wrap-as (append (i386:accu->base)
                                                    (if (eq? size 1) '()
                                                        (append
                                                         (if (<= size 4) '()
                                                             (i386:accu+accu))
                                                         (if (<= size 8) '()
                                                             (i386:accu+base))
                                                         (i386:accu-shl 2)))))
                                   ((ident->base info) array)
                                   (wrap-as (i386:accu+base))))))

      ;; g_cells[<expr>].type
      ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
       (let* ((type (ident->type info array))
              (fields (or (type->description info type) '()))
              (field-size 4) ;; FIXME:4, not fixed
              (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
              (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
         (append-text info (wrap-as (append (i386:accu+value offset))))))

      ((d-sel (ident ,field) (p-expr (ident ,name)))
       (let* ((type (ident->type info name))
              (fields (or (type->description info type) '()))
              (field-size 4) ;; FIXME
              (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
              (text (.text info)))
         (append-text info (append ((ident->accu info) name)
                                   (wrap-as (i386:accu+value offset))))))

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

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

(define (make-type name type size description)
  (cons name (list type size description)))

(define (enum->type name fields)
  (make-type name 'enum 4 fields))

(define (struct->type name fields)
  (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME

(define (decl->type o)
  (pmatch o
    ((fixed-type ,type) type)
    ((struct-ref (ident ,name)) (list "struct" name))
    ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
     (list "struct" name)) ;; FIXME
    ((typename ,name) name)
    (_
     (stderr "SKIP: decl type=~s\n" o)
     barf
     o)))

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

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

(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)
    (wrap-as (i386:Xjump n)))
  (define (jump-nz n)
    (wrap-as (i386:Xjump-nz n)))
  (define (jump-z n)
    (wrap-as (i386:Xjump-z n)))
  (define (statement->info info body-length)
    (lambda (o)
      (pmatch o
        ((break) (append-text info (jump body-length)))
        (_ ((ast->info info) o)))))
  (define (test->text test)
    (let ((value (pmatch test
                   (0 0)
                   ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
                   ((p-expr (fixed ,value)) (cstring->number value))
                   ((neg (p-expr (fixed ,value))) (- (cstring->number value))))))
      (lambda (n)
        (append (wrap-as (i386:accu-cmp-value value))
                (jump-z (+ (length (text->list (jump 0)))
                           (if (= n 0) 0
                               (* n (length (text->list ((test->text 0) 0)))))))))))
  (define (cases+jump cases clause-length)
    (append-text info
                 (append
                  (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
                  (if (null? cases) '()
                      (jump clause-length)))))
  (lambda (o)
    (lambda (body-length)
      (let loop ((o o) (cases '()) (clause #f))
        (pmatch o
          ((case ,test ,statement)
           (loop statement (append cases (list (test->text test))) clause))
          ((default ,statement)
           (loop statement cases clause))
          ((compd-stmt (block-item-list))
           (loop '() cases clause))
          ((compd-stmt (block-item-list . ,elements))
           (let ((clause (or clause (cases+jump cases 0))))
             (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
                   ((statement->info clause body-length) (car elements)))))
          (()
           (let* ((cases-length (length (.text (cases+jump cases 0))))
                  (clause-text (list-tail (.text clause) cases-length))
                  (clause-length (length (text->list clause-text))))
             (clone clause #:text
                    (append (.text (cases+jump cases clause-length))
                            clause-text))))
          (_
           (let ((clause (or clause (cases+jump cases 0))))
             (loop '() cases
                   ((statement->info clause body-length) o)))))))))

(define (test->jump->info info)
  (define (jump type . test)
    (lambda (o)
      (let* ((text (.text info))
             (info (clone info #:text '()))
             (info ((ast->info info) o))
             (jump-text (lambda (body-length)
                          (wrap-as (type body-length)))))
        (lambda (body-length)
          (clone info #:text
                 (append text
                         (.text info)
                         (if (null? test) '() (car test))
                         (jump-text body-length)))))))
  (lambda (o)
    (pmatch o
      ;; unsigned
      ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
      ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
      ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
      ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))

      ((le ,a ,b) ((jump i386:Xjump-g) o))
      ((lt ,a ,b) ((jump i386:Xjump-ge) o))
      ((ge ,a ,b) ((jump i386:Xjump-g) o))
      ((gt ,a ,b) ((jump i386:Xjump-ge) o))

      ((ne ,a ,b) ((jump i386:Xjump-nz) o))
      ((eq ,a ,b) ((jump i386:Xjump-nz) o))
      ((not _) ((jump i386:Xjump-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)))))))
      ((or ,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)))

              (jump-text (wrap-as (i386:Xjump 0)))
              (jump-length (length (text->list jump-text)))

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

              (jump-text (wrap-as (i386:Xjump b-length))))

         (lambda (body-length)
           (clone info #:text
                  (append text
                          (.text (a-jump jump-length))
                          jump-text
                          (.text (b-jump body-length)))))))

      ((array-ref . _) ((jump i386:jump-byte-z
                              (wrap-as (i386:accu-zero?))) o))

      ((de-ref _) ((jump i386:jump-byte-z
                         (wrap-as (i386:accu-zero?))) o))

      ((assn-expr (p-expr (ident ,name)) ,op ,expr)
       ((jump i386:Xjump-z
              (append
               ((ident->accu info) name)
               (wrap-as (i386:accu-zero?)))) o))

      (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) 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))
    ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list (param-decl (decl-spec-list (type-spec (void)))))))))
     (cons type name)) ;; FIXME function / int
    ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
     (cons type name)) ;; FIXME: ptr/char
    (_ (stderr "struct-field: no match: ~s\n" o) barf)))

(define (ast->type o)
  (pmatch o
    ((fixed-type ,type)
     type)
    ((struct-ref (ident ,type))
     (list "struct" type))
    (_ (stderr "SKIP: type=~s\n" o)
       "int")))

(define i386:type-alist
  '(("char" . (builtin 1 #f))
    ("int" . (builtin 4 #f))))

(define (type->size info o)
  ;;(stderr  "types=~s\n" (.types info))
  ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
  (pmatch o
    ((decl-spec-list (type-spec (fixed-type ,type)))
     (type->size info type))
    ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
     (type->size info type))
    (_ (let ((type (assoc-ref (.types info) o)))
         (if type (cadr type)
             (begin
               (stderr "***TYPE NOT FOUND**: o=~s\n" o)
               barf
               4))))))

(define (ident->decl info o)
  ;; (stderr "ident->decl o=~s\n" o)
  ;; (stderr "  types=~s\n" (.types info))
  ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
  ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
  (or (assoc-ref (.locals info) o)
      (assoc-ref (.globals info) o)
      (begin
        (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
        (assoc-ref (.functions info) o))))

(define (ident->type info o)
  (and=> (ident->decl info o) car))

(define (ident->pointer info o)
  (let ((local (assoc-ref (.locals info) o)))
    (if local (local:pointer local)
        (or (and=> (ident->decl info o) global:pointer) 0))))

(define (type->description info o)
  ;; (stderr  "type->description =~s\n" o)  
  ;; (stderr  "types=~s\n" (.types info))
  ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
  ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
  (pmatch o
    ((decl-spec-list (type-spec (fixed-type ,type)))
     (type->description info type))
    ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
     (type->description info type))
    (_ (caddr (assoc-ref (.types info) o)))))

(define (local? o) ;; formals < 0, locals > 0
  (positive? (local:id o)))

(define (ast->info info)
  (lambda (o)
    (let ((globals (.globals info))
          (locals (.locals info))
          (constants (.constants info))
          (text (.text info)))
      (define (add-local locals name type pointer)
        (let* ((id (1+ (length (filter local? (map cdr locals)))))
               (locals (cons (make-local name type pointer id) locals)))
          locals))

      ;; (stderr "\n ast->info=~s\n" o)
      ;; (stderr "  globals[~a=>~a]: ~a\n" (length globals) (length (append-map cdr globals)) (map (lambda (s) (if (string? s) (string-delete #\newline s))) (map car globals)))
      ;; (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)))
         info)

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

        ((break)
         (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (text->list text)))))))

        ;; FIXME: expr-stmt wrapper?
        (trans-unit info)
        ((expr-stmt) info)

        ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
        
        ((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))))

        ((if ,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-jump-text (wrap-as (i386:Xjump 0)))
                (then-jump-length (length (text->list then-jump-text)))
                (then-length (+ (length (text->list then-text)) then-jump-length))

                (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
                (else-info ((ast->info then+jump-info) else))
                (text-else-info (.text else-info))
                (else-text (list-tail text-else-info (length (.text then+jump-info))))
                (else-length (length (text->list else-text)))

                (text+test-text (.text (test-jump->info then-length)))
                (test-text (list-tail text+test-text text-length))
                (then-jump-text (wrap-as (i386:Xjump else-length))))

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

        ;; Hmm?
        ((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 (wrap-as (i386:Xjump 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 (wrap-as (i386:Xjump 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* ((expr ((expr->accu info) expr))
                (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 '())) ;; FIXME: goto in body...

                (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 ((expr->accu info) 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 (wrap-as (i386:Xjump (+ body-length step-length))))

                (jump-text (wrap-as (i386:Xjump (- (+ 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 (list-tail (.globals body-info) (length globals)))
                  #:locals locals)))

        ((while ,test ,body)
         (let* ((skip-info (lambda (body-length test-length)
                             (clone info
                                    #:text (append text (wrap-as (i386:Xjump body-length)))
                                    #:break (cons (+ (length (text->list text)) body-length test-length
                                                     (length (i386:Xjump 0)))
                                                  (.break info)))))
                (text (.text (skip-info 0 0)))
                (text-length (length text))
                (body-info (lambda (body-length test-length)
                             ((ast->info (skip-info body-length test-length)) body)))

                (body-text (list-tail (.text (body-info 0 0)) text-length))
                (body-length (length (text->list body-text)))

                (empty (clone info #:text '()))
                (test-jump->info ((test->jump->info empty) test))
                (test+jump-info (test-jump->info 0))
                (test-length (length (text->list (.text test+jump-info))))

                (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
                (jump-length (length (text->list jump-text)))

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

                (body-info (body-info body-length (length (text->list test-text)))))

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

        ((do-while ,body ,test)
         (let* ((text-length (length text))

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

                (empty (clone info #:text '()))
                (test-jump->info ((test->jump->info empty) test))
                (test+jump-info (test-jump->info 0))
                (test-length (length (text->list (.text test+jump-info))))

                (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
                (jump-length (length (text->list jump-text)))

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

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

        ((goto (ident ,label))
         (let* ((jump (lambda (n) (i386:XXjump n)))
                (offset (+ (length (jump 0)) (length (text->list text)))))
           (append-text info (append 
                              (list (lambda (f g ta t d)
                                      (jump (- (label-offset (.function info) label f) offset))))))))

        ((return ,expr)
         (let ((info ((expr->accu info) expr)))
           (append-text info (append  (wrap-as (i386:ret)))))) 

        ;; DECL

        ;; int i;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
         (if (.function info)
             (clone info #:locals (add-local locals name type 0))
             (clone info #:globals (append globals (list (ident->global name type 0 0))))))

        ;; 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 ((value (cstring->number value)))
           (if (.function info)
               (let* ((locals (add-local locals name type 0))
                      (info (clone info #:locals locals)))
                 (append-text info ((value->ident info) name value)))
               (clone info #:globals (append globals (list (ident->global name type 0 value)))))))

        ;; char c = 'A';
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
         (if (not (.function info)) decl-barf0)
         (let* ((locals (add-local locals name type 0))
                (info (clone info #:locals locals))
                (value (char->integer (car (string->list value)))))
           (append-text info ((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 ((value (- (cstring->number value))))
           (if (.function info)
               (let* ((locals (add-local locals name type 0))
                      (info (clone info #:locals locals)))
                 (append-text info ((value->ident info) name value)))
               (clone info #:globals (append globals (list (ident->global name type 0 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))))))
         (if (not (.function info)) decl-barf2)
         (let* ((locals (add-local locals name type 0))
                (info (clone info #:locals locals)))
           (append-text info (append ((ident->accu info) local)
                                     ((accu->ident info) name)))))

        ;; char *p = "t.c";
        ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
         (when (not (.function info))
           (stderr "o=~s\n" o)
           decl-barf3)
         (let* ((locals (add-local locals name type 1))
                (globals (append globals (list (string->global string))))
                (info (clone info #:locals locals #:globals globals)))
           (append-text info (append
                              (list (lambda (f g ta t d)
                                      (append
                                       (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
                              ((accu->ident info) name)))))
        
        ;; char *p = 0;
        ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
         (let ((value (cstring->number value)))
           (if (.function info)
               (let* ((locals (add-local locals name type 1))
                      (info (clone info #:locals locals)))
                 (append-text info (append (wrap-as (i386:value->accu value))
                                           ((accu->ident info) name))))
               (clone info #:globals (append globals (list (ident->global name type 0 value)))))))

        ;; char arena[20000];
        ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
         (let ((type (ast->type type)))
           (if (.function info)
               TODO:decl-array 
               (let* ((globals (.globals info))
                      (count (cstring->number count))
                      (size (type->size info type))
                      (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
                      (globals (append globals (list array))))
                 (clone info #:globals globals)))))

        ;;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)))))))
         ;;(stderr "0TYPE: ~s\n" type)
         (if (.function info)
             (let* ((locals (add-local locals name type 1))
                    (info (clone info #:locals locals)))
               (append-text info (append ((ident->accu info) name)
                                         ((accu->ident info) value)))) ;; FIXME: deref?
             (let* ((globals (append globals (list (ident->global name type 1 0))))
                    (info (clone info #:globals globals)))
               (append-text info (append ((ident->accu info) name)
                                         ((accu->ident info) value)))))) ;; FIXME: deref?

        ;; SCM tmp;
        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
         ;;(stderr  "1TYPE: ~s\n" type)
         (if (.function info)
             (clone info #:locals (add-local locals name type 0))
             (clone info #:globals (append globals (list (ident->global name type 0 0))))))

        ;; SCM g_stack = 0;
        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
         ;;(stderr  "2TYPE: ~s\n" type)
         (let ((value (cstring->number value)))
           (if (.function info)
               (let* ((locals (add-local locals name type 0))
                      (info (clone info #:locals locals)))
                 (append-text info ((value->ident info) name value)))
               (let ((globals (append globals (list (ident->global name type 0 value)))))
                 (clone info #:globals globals)))))

        ;; SCM g_stack = 0; // comment
        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
         ((ast->info info) (list-head o (- (length o) 1))))

        ;; SCM i = argc;
        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
         ;;(stderr  "3TYPE: ~s\n" type)
         (if (.function info)
             (let* ((locals (add-local locals name type 0))
                    (info (clone info #:locals locals)))
               (append-text info (append ((ident->accu info) local)
                                         ((accu->ident info) name))))
             (let* ((globals (append globals (list (ident->global name type 0 0))))
                    (info (clone info #:globals globals)))
               (append-text info (append ((ident->accu info) local)
                                         ((accu->ident info) name))))))

        ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)) (initzer ,initzer))))
         (let* ((locals (add-local locals name type 1))
                (info (clone info #:locals locals))
                (empty (clone info #:text '()))
                (accu ((expr->accu empty) initzer)))
           (clone info
                  #:text
                  (append text
                          (.text accu)
                          ((accu->ident info) name)
                          (list (lambda (f g ta t d)
                                  (append (i386:value->base ta)
                                          (i386:accu+base)))))
                  #:locals locals)))

        ;; 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)))))))
         ;;(stderr  "6TYPE: ~s\n" type)
         (if (.function info)
             (let* ((locals (add-local locals name type 1))
                    (info (clone info #:locals locals)))
               (append-text info (append ((ident->accu info) value)
                                         ((accu->ident info) name))))
             (let* ((globals (append globals (list (ident->global name type 1 0))))
                    (here (data-offset name globals))
                    (there (data-offset value globals)))
               (clone info
                      #:globals globals
                      #:init (append (.init info)
                                     (list (lambda (functions globals ta t d data)
                                             (append
                                              (list-head data here)
                                              ;;; FIXME: type
                                              ;;; char *x = arena;
                                              (int->bv32 (+ d (data-offset value globals)))
                                              ;;; char *y = x;
                                              ;;;(list-head (list-tail data there) 4)
                                              (list-tail data (+ here 4))))))))))

        ;; char *p = g_cells;
        ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
         ;;(stderr  "7TYPE: ~s\n" type)
         (let ((type (decl->type type)))
           ;;(stderr "0DECL: ~s\n" type)
           (if (.function info)
               (let* ((locals (add-local locals name type  1))
                      (info (clone info #:locals locals)))
                 (append-text info (append ((ident->accu info) value)
                                           ((accu->ident info) name))))
               (let* ((globals (append globals (list (ident->global name type 1 0))))
                      (here (data-offset name globals)))
                 (clone info
                        #:globals globals
                        #:init (append (.init info)
                                       (list (lambda (functions globals ta t d data)
                                               (append
                                                (list-head data here)
                                              ;;; FIXME: type
                                              ;;; char *x = arena;p
                                                (int->bv32 (+ d (data-offset value globals)))
                                                (list-tail data (+ here 4)))))))))))

        ;; enum 
        ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
         (let ((type (enum->type name fields))
               (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 (struct->type (list "struct" name) (map struct-field fields))))
           ;;(stderr "type: ~a\n" type)
           (clone info #:types (append (.types info) (list type)))))

        ;; DECL
        ;;
        ;; struct f = {...};
        ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
         (let* ((type (decl->type type))
                ;;(foo (stderr "1DECL: ~s\n" type))
                (fields (type->description info type))
                (size (type->size info type))
                (field-size 4))  ;; FIXME:4, not fixed
           ;;(stderr  "7TYPE: ~s\n" type)
           (if (.function info)
               (let* ((globals (append globals (filter-map initzer->global initzers)))
                      (locals (let loop ((fields (cdr fields)) (locals locals))
                                (if (null? fields) locals
                                    (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
                      (locals (add-local locals name type -1))
                      (info (clone info #:locals locals #:globals globals))
                      (empty (clone info #:text '())))
                 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
                   (if (null? fields) info
                       (let ((offset (* field-size (car fields)))
                             (initzer (car initzers)))
                         (loop (cdr fields) (cdr initzers)
                               (clone info #:text
                                      (append
                                       (.text info)
                                       ((ident->accu info) name)
                                       (wrap-as (append (i386:accu->base)))
                                       (.text ((expr->accu empty) initzer))
                                       (wrap-as (i386:accu->base-address+n offset)))))))))
               (let* ((globals (append globals (filter-map initzer->global initzers)))
                      (global (make-global name type -1 (string->list (make-string size #\nul))))
                      (globals (append globals (list global)))
                      (here (data-offset name globals))
                      (info (clone info #:globals globals))
                      (field-size 4))
                 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
                   (if (null? fields) info
                       (let ((offset (* field-size (car fields)))
                             (initzer (car initzers)))
                         (loop (cdr fields) (cdr initzers)
                               (clone info #:init
                                      (append
                                       (.init info)
                                       (list (lambda (functions globals ta t d data)
                                               (append
                                                (list-head data (+ here offset))
                                                (initzer->data info functions globals ta t d (car initzers))
                                                (list-tail data (+ here offset field-size)))))))))))))))


        ;;char cc = g_cells[c].cdr;  ==> generic?
        ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
         (let ((type (decl->type type)))
           (if (.function info)
               (let* ((locals (add-local locals name type 0))
                      (info (clone info #:locals locals)))
                 (clone info #:text
                        (append (.text ((expr->accu info) initzer))
                                ((accu->ident info) name))))
               (let* ((globals (append globals (list (ident->global name type 1 0))))
                      (here (data-offset name globals)))
                 (clone info
                        #:globals globals
                        #:init (append (.init info)
                                       (list (lambda (functions globals ta t d data)
                                               (append
                                                (list-head data here)
                                                (initzer->data info functions globals ta t d initzer)
                                                (list-tail data (+ here 4)))))))))))


        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
         info)

        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
         info)

        ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
         (let ((types (.types info)))
           (clone info #:types (cons (cons name (assoc-ref types type)) types))))

        ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
         (format (current-error-port) "SKIP: typedef=~s\n" o)
         info)

        ((decl (@ ,at))
         (format (current-error-port) "SKIP: at=~s\n" o)
         info)

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

        ;; ...
        ((gt . _) ((expr->accu info) o))
        ((ge . _) ((expr->accu info) o))
        ((ne . _) ((expr->accu info) o))
        ((eq . _) ((expr->accu info) o))
        ((le . _) ((expr->accu info) o))
        ((lt . _) ((expr->accu info) o))
        ((lshift . _) ((expr->accu info) o))
        ((rshift . _) ((expr->accu info) o))

        ;; EXPR
        ((expr-stmt ,expression)
         (let ((info ((expr->accu info) expression)))
           (append-text info (wrap-as (i386:accu-zero?)))))

        ;; FIXME: why do we get (post-inc ...) here
        ;; (array-ref
        (_ (let ((info ((expr->accu info) o)))
             (append-text info (wrap-as (i386:accu-zero?)))))))))

(define (initzer->data info functions globals ta t d o)
  (pmatch o
    ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
    ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
    ((initzer (ref-to (p-expr (ident ,name))))
     ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
     (int->bv32 (+ ta (function-offset name functions))))
    ((initzer (p-expr (ident ,name)))
     (let ((value (assoc-ref (.constants info) name)))
       (int->bv32 value)))
    ((initzer (p-expr (string ,string)))
     (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
    (_ (stderr "initzer->data:SKIP: ~s\n" o)
       barf
       (int->bv32 0))))

(define (info->exe info)
  (display "dumping elf\n" (current-error-port))
  (for-each write-any (make-elf (.functions info) (.globals info) (.init 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)))
       (wrap-as (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 (formal:ptr o)
  (pmatch o
    ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
     1)
    ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
     0)
    (_
     (stderr "formal:ptr[~a] => 0\n" o)
     0)))

(define (formals->locals o)
  (pmatch o
    ((param-list . ,formals)
     (let ((n (length formals)))
       (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
    (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
       barf)))

(define (function->info info)
  (lambda (o)
    ;;(stderr "function->info o=~s\n" o)
    ;;(stderr "formals=~s\n" (.formals o))
    (let* ((name (.name o))
           (formals (.formals o))
           (text (formals->text formals))
           (locals (formals->locals formals)))
      (format (current-error-port) "compiling ~s\n" name)
      ;;(stderr "locals=~s\n" locals)
      (let loop ((statements (.statements o))
                 (info (clone info #:locals locals #:function (.name o) #:text text)))
        (if (null? statements) (clone info
                                      #:function #f
                                      #:functions (append (.functions info) (list (cons name (.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 (compile)
  (stderr "COMPILE\n")
  (let* ((ast (mescc))
         (info (make <info>
                 #:functions i386:libc
                 #:types i386:type-alist))
         (ast (append libc ast))
         (info ((ast->info info) ast))
         (info ((ast->info info) _start)))
    (info->exe info)))