;;; -*-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* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()))
  (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)))))

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

(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* ((info ((expr->accu info) index))
                (type (ident->type info array))
                (size (type->size info type)))
           (append-text info (append
                              ;; immediate: (i386:value->accu (* size index))
                              ;; * size cells: * length * 4 = * 12
                              (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 (append (case size
                                                 ((1) (i386:byte-base-mem->accu))
                                                 ((4) (i386:base-mem->accu))
                                                 (else (i386:accu+base)))))))))

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

        ;; g_cells[10].type
        ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
         (let* ((type (ident->type info array))
                (fields (or (type->description info type) '()))
                (size (type->size info type))
                (count (length fields))
                (field-size 4) ;; FIXME:4, not fixed
                (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
                (index (cstring->number index))
                (text (.text info)))
           (append-text info (append
                              (wrap-as (append (i386:value->base index)
                                               (i386:base->accu)
                                               (if (<= count 1) '() (i386:accu+accu))
                                               (if (<= count 2) '() (i386:accu+base))
                                               (i386:accu-shl 2)))
                              ((ident->base info) array)
                              (wrap-as (i386:base-mem+n->accu offset))))))
        
        ;; g_cells[x].type
        ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
         (let* ((type (ident->type info array))
                (fields (or (type->description info type) '()))
                (size (type->size info type))
                (count (length fields))
                (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->base info) index)
                                     (wrap-as (append (i386:base->accu)
                                                      (if (<= count 1) '() (i386:accu+accu))
                                                      (if (<= count 2) '() (i386:accu+base))
                                                      (i386:accu-shl 2)))
                                     ((ident->base info) array)
                                     (wrap-as (i386:base-mem+n->accu offset))))))

        ;; g_functions[g_cells[fn].cdr].arity
        ;; INDEX0: g_cells[fn].cdr

        ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
        ;;((d-sel (ident ,arity) (array-ref (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells)))) (p-expr (ident ,g_functions)))))
        ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
         (let* ((empty (clone info #:text '()))
                (index ((expr->accu empty) index))
                (type (ident->type info array))
                (fields (or (type->description info type) '()))
                (size (type->size info type))
                (count (length fields))
                (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))))
                (text (.text info)))
           (append-text info (append (.text index)
                                     (wrap-as (append (i386:accu->base)
                                                      (if (<= count 1) '() (i386:accu+accu))
                                                      (if (<= count 2) '() (i386:accu+base))
                                                      (i386:accu-shl 2)))
                                     ((ident->base info) array)
                                     (wrap-as (i386:base-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 (type-name (decl-spec-list (type-spec (typename "SCM"))) (abs-declr (declr-fctn (declr-scope (abs-declr (pointer))) (param-list (param-decl (decl-spec-list (type-spec (typename "SCM")))))))) (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "functions"))))))
        ((cast ,cast ,o)
         ((expr->accu info) o))

        ;; *p++ = b;
        ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
         (when (not (equal? op "="))
           (stderr "OOOPS0.0: op=~s\n" op)
           barf)
         (let* ((empty (clone info #:text '()))
                (base ((expr->base empty) b)))
           (append-text info (append (.text base)
                                     ((base->ident-address info) name)
                                     ((ident->accu info) name)
                                     ((ident-add info) name 1)))))

        ;; *p-- = b;
        ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
         (when (not (equal? op "="))
           (stderr "OOOPS0.0: op=~s\n" op)
           barf)
         (let* ((empty (clone info #:text '()))
                (base ((expr->base empty) b)))
           (append-text info (append (.text base)
                                     ((base->ident-address info) name)
                                     ((ident->accu info) name)
                                     ((ident-add info) name -1)))))

        ;; CAR (x) = 0
        ;; TYPE (x) = PAIR;
        ((assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b)
         (when (not (equal? op "="))
           (stderr "OOOPS0: op=~s\n" op)
           barf)
         (let* ((empty (clone info #:text '()))
                (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
                (base ((expr->base empty) b))
                (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))))))))                )
           (append-text info (append (.text expr)
                                     (.text base)
                                     (wrap-as (i386:base->accu-address)))))) ; FIXME: size


        ;; i = 0;
        ;; c = f ();
        ;; i = i + 48;
        ;; p = g_cell;
        ((assn-expr (p-expr (ident ,name)) (op ,op) ,b)
         (when (and (not (equal? op "="))
                    (not (equal? op "+="))
                    (not (equal? op "-=")))
           (stderr "OOOPS1: op=~s\n" op)
           barf)
         (let* ((empty (clone info #:text '()))
                (base ((expr->base empty) b)))
           (append-text info (append (.text base)
                                     (if (equal? op "=") '()
                                         (append ((ident->accu info) name)
                                                 (wrap-as (append (if (equal? op "+=") (i386:accu+base)
                                                                      (i386:accu-base))
                                                                  (i386:accu->base)))))
                                     ;;assign:
                                     ((base->ident info) name)
                                     (wrap-as (i386:base->accu))))))
        
        ;; *p = 0;
        ((assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b)
         (when (not (equal? op "="))
           (stderr "OOOPS2: op=~s\n" op)
           barf)
         (let* ((empty (clone info #:text '()))
                (base ((expr->base empty) b)))
           (append-text info (append (.text base)
                                     ;;assign:
                                     ((base->ident-address info) array)
                                     (wrap-as (i386:base->accu))))))

        ;; g_cells[<expr>] = <expr>;
        ((assn-expr (array-ref ,index (p-expr (ident ,array))) (op ,op) ,b)
         (when (not (equal? op "="))
           (stderr "OOOPS3: op=~s\n" op)
           barf)
         (let* ((info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
                (info ((expr->+base info) b))
                (type (ident->type info array))
                (size (type->size info type))
                (ptr (ident->pointer info array)))
           (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))))))))))

        (_
         (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->base info) ;; JUNKME
  (lambda (o)
    (let ((info ((expr->accu info) o)))
      (clone info
             #:text (append (wrap-as (i386:push-accu))
                            (.text info)
                            (wrap-as (append (i386:accu->base)
                                             (i386:pop-accu))))))))

(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[10].type
      ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
       (let* ((type (ident->type info array))
              (fields (or (type->description info type) '()))
              (size (type->size info type))
              (count (length fields))
              (field-size 4) ;; FIXME:4, not fixed
              (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
              (index (cstring->number index))
              (text (.text info)))
         (append-text info (append (wrap-as (append (i386:value->base index)
                                                    (i386:base->accu)
                                                    (if (<= count 1) '()
                                                        (i386:accu+accu))
                                                    (if (<= count 2) '()
                                                        (i386:accu+base))
                                                    (i386:accu-shl 2)))
                                   ;; de-ref: g_cells, non: arena
                                   ;;((ident->base info) array)
                                   ((ident->base info) array)
                                   (wrap-as (append (i386:accu+base)
                                                    (i386:accu+value offset)))))))

      ;; g_cells[x].type
      ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
       (let* ((type (ident->type info array))
              (fields (or (type->description info type) '()))
              (size (type->size info type))
              (count (length fields))
              (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->base info) index)
                                   (wrap-as (append (i386:base->accu)
                                                    (if (<= count 1) '()
                                                        (i386:accu+accu))
                                                    (if (<= count 2) '()
                                                        (i386:accu+base))
                                                    (i386:accu-shl 2)))
                                   ;; de-ref: g_cells, non: arena
                                   ;;((ident->base info) array)
                                   ((ident->base info) array)
                                   (wrap-as (append (i386:accu+base)
                                                    (i386:accu+value offset)))))))

      ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
      ((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 (statement->info info body-length)
    (lambda (o)
      (pmatch o
        ((break) (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)

         (define (test->text value clause-length)
           (append (wrap-as (i386:accu-cmp-value value))
                   (jump-nz clause-length)))
         (let* ((value (assoc-ref (.constants info) constant))
                (test-info (append-text info (test->text value 0)))
                (text-length (length (.text test-info)))
                (clause-info (let loop ((elements elements) (info test-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))))
           (clone info #:text (append
                               (.text info)
                               (test->text value clause-length)
                               clause-text)
                  #:globals (.globals clause-info)))))

      ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
       (lambda (body-length)

         (define (test->text value clause-length)
           (append (wrap-as (i386:accu-cmp-value value))
                   (jump-nz clause-length)))
         (let* ((value (cstring->number value))
                (test-info (append-text info (test->text value 0)))
                (text-length (length (.text test-info)))
                (clause-info (let loop ((elements elements) (info test-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))))
           (clone info #:text (append
                               (.text info)
                               (test->text value clause-length)
                               clause-text)
                  #:globals (.globals clause-info)))))

      ((case (neg (p-expr (fixed ,value))) ,statement)
       ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))

      ((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) info
                 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))

      ((case (p-expr (ident ,constant)) ,statement)
       ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))

      ((case (p-expr (fixed ,value)) ,statement)
       ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))

      ((default ,statement)
       ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))

      (_ (stderr "no case match: ~a\n" o) barf)
      )))

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

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

        ;; FIXME: support break statement (see switch/case)
        ((while ,test ,body)
         (let* ((skip-info (lambda (body-length)
                             (clone info #:text (append text
                                                        (wrap-as (i386:Xjump body-length))))))
                (text (.text (skip-info 0)))
                (text-length (length text))

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

                (body-info (body-info body-length))

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

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