mes/module/mescc/compile.scm

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019,2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2023 Andrius Štikonas <andrius@stikonas.eu>
;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech>
;;; Copyright © 2021 W. J. van der Laan <laanwj@protonmail.com>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(define-module (mescc compile)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (system base pmatch)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 pretty-print)
  #:use-module (nyacc lang c99 pprint)

  #:use-module (mes guile)
  #:use-module (mes misc)

  #:use-module (mescc preprocess)
  #:use-module (mescc info)
  #:use-module (mescc as)
  #:use-module (mescc i386 as)
  #:use-module (mescc M1)
  #:export (c99-ast->info
            c99-input->info
            c99-input->object))

(define mes? (pair? (current-module)))
(define mes-or-reproducible? #t)
(define (cc-amd? info) #f)              ; use AMD calling convention?
;; (define %reduced-register-count #f)     ; use all registers?
(define %reduced-register-count 2)      ; use reduced instruction set
(define (max-registers info)
  (if %reduced-register-count %reduced-register-count
   (length (append (.registers info) (.allocated info)))))

(define* (c99-input->info info #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
  (let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
    (c99-ast->info info ast #:verbose? verbose?)))

(define* (c99-ast->info info o #:key verbose?)
  (when verbose?
    (format (current-error-port) "compiling: input\n")
    (set! mescc:trace mescc:trace-verbose))
  (let ((info (ast->info o info)))
    (clean-info info)))

(define (clean-info o)
  (make <info>
    #:functions (filter (compose pair? function:text cdr) (.functions o))
    #:globals (.globals o)
    #:types (.types o)))

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

(define (enum->type-entry name fields)
  (cons `(tag ,name) (make-type 'enum 4 fields)))

(define (struct->type-entry info name fields)
  (let ((size (apply + (map (compose (cut ->size <> info) cdr) fields))))
    (cons `(tag ,name) (make-type 'struct size fields))))

(define (union->type-entry info name fields)
  (let ((size (apply max (map (compose (cut ->size <> info) cdr) fields))))
    (cons `(tag ,name) (make-type 'union size fields))))

(define (signed? o)
  (let ((type (->type o)))
    (cond ((type? type) (eq? (type:type type) 'signed))
          (else #f))))

(define (unsigned? o)
    (let ((type (->type o)))
    (cond ((type? type) (eq? (type:type type) 'unsigned))
          (else #t))))

(define (->size o info)
  (cond ((and (type? o) (eq? (type:type o) 'union))
         (apply max (map (compose (cut ->size <> info) cdr) (struct->fields o))))
        ((type? o) (type:size o))
        ((pointer? o) (->size (get-type "*" info) info))
        ((c-array? o) (* (c-array:count o) ((compose (cut ->size <> info) c-array:type) o)))
        ((local? o) ((compose (cut ->size <> info) local:type) o))
        ((global? o) ((compose (cut ->size <> info) global:type) o))
        ((bit-field? o) ((compose (cut ->size <> info) bit-field:type) o))
        ((and (pair? o) (pair? (car o)) (bit-field? (cdar o))) ((compose (cut ->size <> info) cdar) o))
        ((string? o) (->size (get-type o info) info))
        (else (error "->size>: not a <type>:" o))))

(define (ast->type o info)
  (define (type-helper o info)
    (if (getenv "MESC_DEBUG")
        (format (current-error-port) "type-helper: ~s\n" o))
    (pmatch o
      (,t (guard (type? t)) t)
      (,p (guard (pointer? p)) p)
      (,a (guard (c-array? a)) a)
      (,b (guard (bit-field? b)) b)

      ((char ,value) (get-type "char" info))
      ((enum-ref . _) (get-type "default" info))
      ((fixed ,value)
       (let ((type (cond ((string-suffix? "ULL"value) "unsigned long long")
                         ((string-suffix? "UL" value) "unsigned long")
                         ((string-suffix? "U" value) "unsigned")
                         ((string-suffix? "LL" value) "long long")
                         ((string-suffix? "L" value) "long")
                         (else "default"))))
         (get-type type info)))
      ((float ,float) (get-type "float" info))
      ((void) (get-type "void" info))

      ((ident ,name) (ident->type info name))
      ((tag ,name) (or (get-type o info)
                       o))

      (,name (guard (string? name))
             (let ((type (get-type name info)))
               (ast->type type info)))

      ((type-name (decl-spec-list ,type) (abs-declr (pointer . ,pointer)))
       (let ((rank (pointer->rank `(pointer ,@pointer)))
             (type (ast->type type info)))
         (rank+= type rank)))

      ((type-name ,type) (ast->type type info))
      ((type-spec ,type) (ast->type type info))

      ((sizeof-expr ,expr) (get-type "unsigned" info))
      ((sizeof-type ,type) (get-type "unsigned" info))

      ((string ,string) (make-c-array (get-type "char" info) (1+ (string-length string))))

      ((decl-spec-list (type-spec ,type)) (ast->type type info))

      ((fctn-call (p-expr (ident ,name)) . _)
       (or (and=> (assoc-ref (.functions info) name) function:type)
           (get-type "default" info)))

      ((fctn-call (de-ref (p-expr (ident ,name))) . _)
       (or (and=> (assoc-ref (.functions info) name) function:type)
           (get-type "default" info)))

      ((fixed-type ,type) (ast->type type info))
      ((float-type ,type) (ast->type type info))
      ((type-spec ,type) (ast->type type info))
      ((typename ,type) (ast->type type info))

      ((array-ref ,index ,array) (rank-- (ast->type array info)))

      ((de-ref ,expr) (rank-- (ast->type expr info)))
      ((ref-to ,expr) (rank++ (ast->type expr info)))

      ((p-expr ,expr) (ast->type expr info))
      ((pre-inc ,expr) (ast->type expr info))
      ((post-inc ,expr) (ast->type expr info))

      ((struct-ref (ident ,type))
       (or (get-type type info)
           (let ((struct (if (pair? type) type `(tag ,type))))
             (ast->type struct info))))
      ((union-ref (ident ,type))
       (or (get-type type info)
           (let ((struct (if (pair? type) type `(tag ,type))))
             (ast->type struct info))))

      ((struct-def (ident ,name) . _)
       (ast->type `(tag ,name) info))
      ((union-def (ident ,name) . _)
       (ast->type `(tag ,name) info))
      ((struct-def (field-list . ,fields))
       (let ((fields (append-map (struct-field info) fields)))
         (make-type 'struct (apply + (map (cut field:size <> info) fields)) fields)))
      ((union-def (field-list . ,fields))
       (let ((fields (append-map (struct-field info) fields)))
         (make-type 'union (apply + (map (cut field:size <> info) fields)) fields)))
      ((enum-def (enum-def-list . ,fields))
       (get-type "default" info))

      ((d-sel (ident ,field) ,struct)
       (let ((type0 (ast->type struct info)))
         (ast->type (field-type info type0 field) info)))

      ((i-sel (ident ,field) ,struct)
       (let ((type0 (ast->type (rank-- (ast->type struct info)) info)))
         (ast->type (field-type info type0 field) info)))

      ;; arithmetic
      ((pre-inc ,a) (ast->type a info))
      ((pre-dec ,a) (ast->type a info))
      ((post-inc ,a) (ast->type a info))
      ((post-dec ,a) (ast->type a info))
      ((add ,a ,b) (ast->type a info))
      ((sub ,a ,b) (ast->type a info))
      ((bitwise-and ,a ,b) (ast->type a info))
      ((bitwise-not ,a) (ast->type a info))
      ((bitwise-or ,a ,b) (ast->type a info))
      ((bitwise-xor ,a ,b) (ast->type a info))
      ((lshift ,a ,b) (ast->type a info))
      ((rshift ,a ,b) (ast->type a info))
      ((div ,a ,b) (ast->type a info))
      ((mod ,a ,b) (ast->type a info))
      ((mul ,a ,b) (ast->type a info))
      ((not ,a) (ast->type a info))
      ((pos ,a) (ast->type a info))
      ((neg ,a) (ast->type a info))
      ((eq ,a ,b) (ast->type a info))
      ((ge ,a ,b) (ast->type a info))
      ((gt ,a ,b) (ast->type a info))
      ((ne ,a ,b) (ast->type a info))
      ((le ,a ,b) (ast->type a info))
      ((lt ,a ,b) (ast->type a info))

      ;; logical
      ((or ,a ,b) (ast->type a info))
      ((and ,a ,b) (ast->type a info))

      ((cast (type-name ,type) ,expr) (ast->type type info))

      ((cast (type-name ,type (abs-declr ,pointer)) ,expr)
       (let ((rank (pointer->rank pointer)))
         (rank+= (ast->type type info) rank)))

      ((decl-spec-list (type-spec ,type)) (ast->type type info))

      ;;  ;; `typedef int size; void foo (unsigned size u)
      ((decl-spec-list (type-spec ,type) (type-spec ,type2))
       (ast->type type info))

      ((assn-expr ,a ,op ,b) (ast->type a info))

      ((cond-expr _ ,a ,b) (ast->type a info))

      (_ (get-type o info))))

  (let ((type (type-helper o info)))
    (cond ((or (type? type)
               (pointer? type) type
               (c-array? type)) type)
          ((and (equal? type o) (pair? type) (eq? (car type) 'tag)) o)
          ((equal? type o)
           (error "ast->type: not supported: " o))
          (else (ast->type type info)))))

(define (ast->basic-type o info)
  (let ((type (->type (ast->type o info))))
    (cond ((type? type) type)
          ((equal? type o) o)
          (else (ast->type type info)))))

(define (get-type o info)
  (let ((t (assoc-ref (.types info) o)))
    (pmatch t
      ((typedef ,next) (or (get-type next info) o))
      (_ t))))

(define (ast-type->size info o)
  (let ((type (->type (ast->type o info))))
    (cond ((type? type) (type:size type))
          (else (format (current-error-port) "error: ast-type->size: ~s => ~s\n" o type)
                4))))

(define (field:name o)
  (pmatch o
    ((struct (,name ,type ,size ,pointer) . ,rest) name)
    ((union (,name ,type ,size ,pointer) . ,rest) name)
    ((,name . ,type) name)
    (_ (error "field:name not supported:" o))))

(define (field:pointer o)
  (pmatch o
    ((struct (,name ,type ,size ,pointer) . ,rest) pointer)
    ((union (,name ,type ,size ,pointer) . ,rest) pointer)
    ((,name . ,type) (->rank type))
    (_ (error "field:pointer not supported:" o))))

(define (field:size o info)
  (pmatch o
    ((struct . ,type) (apply + (map (cut field:size <> info) (struct->fields type))))
    ((union . ,type) (apply max (map (cut field:size <> info) (struct->fields type))))
    ((,name . ,type) (->size type info))
    (_ (error (format #f "field:size: ~s\n" o)))))

(define (field-field info struct field)
  (let ((fields (type:description struct)))
    (let loop ((fields fields))
      (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
          (let ((f (car fields)))
            (cond ((equal? (car f) field) f)
                  ((and (memq (car f) '(struct union)) (type? (cdr f))
                        (find (lambda (x) (equal? (car x) field)) (struct->fields (cdr f)))))
                  ((eq? (car f) 'bits) (assoc field (cdr f)))
                  (else (loop (cdr fields)))))))))

(define (field-offset info struct field)
  (if (eq? (type:type struct) 'union) 0
      (let ((fields (type:description struct)))
        (let loop ((fields fields) (offset 0))
          (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
              (let ((f (car fields)))
                (cond ((equal? (car f) field) offset)
                      ((and (eq? (car f) 'struct) (type? (cdr f)))
                       (let ((fields (type:description (cdr f))))
                         (find (lambda (x) (equal? (car x) field)) fields)
                         (apply + (cons offset
                                        (map (cut field:size <> info)
                                             (member field (reverse fields)
                                                     (lambda (a b)
                                                       (equal? a (car b) field))))))))
                      ((and (eq? (car f) 'union) (type? (cdr f))
                            (let ((fields (struct->fields (cdr f))))
                              (and (find (lambda (x) (equal? (car x) field)) fields)
                                   offset))))
                      ((and (eq? (car f) 'bits) (assoc-ref (cdr f) field)) offset)
                      (else (loop (cdr fields) (+ offset (field:size f info)))))))))))

(define (field-pointer info struct field)
  (let ((field (field-field info struct field)))
    (field:pointer field)))

(define (field-size info struct field)
  (let ((field (field-field info struct field)))
    (field:size field info)))

(define (field-type info struct field)
  (let ((field (field-field info struct field)))
    (ast->type (cdr field) info)))

(define (struct->fields o)
  (pmatch o
    (_ (guard (and (type? o) (eq? (type:type o) 'struct)))
       (append-map struct->fields (type:description o)))
    (_ (guard (and (type? o) (eq? (type:type o) 'union)))
       (append-map struct->fields (type:description o)))
    ((struct . ,type) (list (car (type:description type))))
    ((union . ,type) (list (car (type:description type))))
    ((bits . ,bits) bits)
    (_ (list o))))

(define (struct->init-fields o) ;; FIXME REMOVEME: non-recursive unroll
  (pmatch o
    (_ (guard (and (type? o) (eq? (type:type o) 'struct)))
       (append-map struct->init-fields (type:description o)))
    (_ (guard (and (type? o) (eq? (type:type o) 'union)))
       (list (car (type:description o))))
    ((struct . ,type) (struct->init-fields type))
    ((union . ,type) (list (car (type:description type))))
    (_ (list o))))

(define (byte->hex.m1 o)
  (string-drop o 2))

(define (asm->m1 o)
  (let ((prefix ".byte "))
    (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
        (let ((s (string-drop o (string-length prefix))))
          (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))

(define (ident->variable info o)
  (or (assoc-ref (.locals info) o)
      (assoc-ref (.statics info) o)
      (assoc-ref (filter (negate static-global?) (.globals info)) o)
      (assoc-ref (.constants info) o)
      (assoc-ref (.functions info) o)
      (begin
        (error "ident->variable: undefined variable:" o))))

(define (static-global? o)
  ((compose global:function cdr) o))

(define (string-global? o)
  (and (pair? (car o))
       (eq? (caar o) #:string)))

(define (ident->type info o)
  (let ((var (ident->variable info o)))
    (cond ((global? var) (global:type var))
          ((local? var) (local:type var))
          ((function? var) (function:type var))
          ((assoc-ref (.constants info) o) (assoc-ref (.types info) "default"))
          ((pair? var) (car var))
          (else (format (current-error-port) "error: ident->type ~s => ~s\n" o var)
                #f))))

(define (local:pointer o)
  (->rank o))

(define (ident->rank info o)
  (->rank (ident->variable info o)))

(define (ident->size info o)
  ((compose type:size (cut ident->type info <>)) o))

(define (pointer->rank o)
  (pmatch o
    ((pointer) 1)
    ((pointer ,pointer) (1+ (pointer->rank pointer)))))

(define (expr->rank info o)
  (->rank (ast->type o info)))

(define (ast->size o info)
  (->size (ast->type o info) info))

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

(define (make-global-entry name storage type value)
  (cons name (make-global name type value storage #f)))

(define (string->global-entry string)
  (let ((value (append (string->list string) (list #\nul))))
   (make-global-entry `(#:string ,string) '() "char" value)))

(define (make-local-entry name type id)
  (cons name (make-local name type id)))

(define* (mescc:trace-verbose name #:optional (type ""))
  (format (current-error-port) "    :~a~a\n" name type))

(define* (mescc:trace name #:optional (type ""))
  #t)

(define (expr->arg o i info)
  (pmatch o
    ((p-expr (string ,string))
     (let* ((globals ((globals:add-string (.globals info)) string))
            (info (clone info #:globals globals))
            (info (allocate-register info))
            (info (append-text info (wrap-as (as info 'label->arg `(#:string ,string) i))))
            (no-swap? (zero? (.pushed info)))
            (info (if (cc-amd? info) info (free-register info)))
            (info (if no-swap? info
                      (append-text info (wrap-as (as info 'swap-r1-stack))))))
       info))
    (_ (let* ((info (expr->register o info))
              (info (append-text info (wrap-as (as info 'r->arg i))))
              (no-swap? (zero? (.pushed info)))
              (info (if (cc-amd? info) info (free-register info)))
              (info (if no-swap? info
                        (append-text info (wrap-as (as info 'swap-r1-stack))))))
         info))))

(define (globals:add-string globals)
  (lambda (o)
    (let ((string `(#:string ,o)))
      (if (assoc-ref globals string) globals
          (append globals (list (string->global-entry o)))))))

(define (ident->r info)
  (lambda (o)
    (cond ((assoc-ref (.locals info) o) => (cut local->r <> info))
          ((assoc-ref (.statics info) o) => (cut global->r <> info))
          ((assoc-ref (filter (negate static-global?) (.globals info)) o) => (cut global->r <> info))
          ((assoc-ref (.constants info) o) => (cut value->r <> info))
          (else (wrap-as (as info 'label->r `(#:address ,o)))))))

(define (value->r o info)
  (wrap-as (as info 'value->r o)))

(define (local->r o info)
  (let* ((type (local:type o)))
    (cond ((or (c-array? type)
               (structured-type? type))
           (wrap-as (as info 'local-ptr->r (local:id o))))
          (else (append (wrap-as (as info 'local->r (local:id o)))
                        (convert-r0 info type))))))

(define (global->r o info)
  (let ((type (global:type o)))
    (cond ((or (c-array? type)
               (structured-type? type)) (wrap-as (as info 'label->r `(#:address ,o))))
          (else (append (wrap-as (as info 'label-mem->r `(#:address ,o)))
                        (convert-r0 info type))))))

(define (ident-address->r info)
  (lambda (o)
    (cond ((assoc-ref (.locals info) o)
           =>
           (lambda (local) (wrap-as (as info 'local-ptr->r (local:id local)))))
          ((assoc-ref (.statics info) o)
           =>
           (lambda (global) (wrap-as (as info 'label->r `(#:address ,global)))))
          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
           =>
           (lambda (global) (wrap-as (as info 'label->r `(#:address ,global)))))
          (else (wrap-as (as info 'label->r `(#:address ,o)))))))

(define (r->local+n-text info local n)
  (let* ((id (local:id local))
         (type (local:type local))
         (type* (cond
                 ((pointer? type) type)
                 ((c-array? type) (c-array:type type))
                 ((type? type) type)
                 (else
                  (format (current-error-port) "unexpected type: ~s\n" type)
                  type)))
         (size (->size type* info))
         (reg-size (->size "*" info))
         (size (if (= size reg-size) 0 size)))
    (case size
      ((0) (wrap-as (as info 'r->local+n id n)))
      ((1) (wrap-as (as info 'byte-r->local+n id n)))
      ((2) (wrap-as (as info 'word-r->local+n id n)))
      ((4) (wrap-as (as info 'long-r->local+n id n)))
      (else
       (format (current-error-port) "unexpected size:~s\n" size)
       (wrap-as (as info 'r->local+n id n))))))

(define (r->ident info)
  (lambda (o)
    (cond ((assoc-ref (.locals info) o)
           =>
           (lambda (local) (let ((size (->size local info))
                                 (r-size (->size "*" info)))
                             (wrap-as (as info 'r->local (local:id local))))))
          ((assoc-ref (.statics info) o)
           =>
           (lambda (global) (let* ((size (->size global info))
                                   (reg-size (->size "*" info))
                                   (size (if (= size reg-size) 0 size)))
                              (case size
                                ((0) (wrap-as (as info 'r->label global)))
                                ((1) (wrap-as (as info 'r->byte-label global)))
                                ((2) (wrap-as (as info 'r->word-label global)))
                                ((4) (wrap-as (as info 'r->long-label global)))
                                (else (wrap-as (as info 'r->label global)))))))
          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
           =>
           (lambda (global) (let* ((size (->size global info))
                                   (reg-size (->size "*" info))
                                   (size (if (= size reg-size) 0 size)))
                              (case size
                                ((0) (wrap-as (as info 'r->label global)))
                                ((1) (wrap-as (as info 'r->byte-label global)))
                                ((2) (wrap-as (as info 'r->word-label global)))
                                ((4) (wrap-as (as info 'r->long-label global)))
                                (else (wrap-as (as info 'r->label global))))))))))

(define (ident-add info)
  (lambda (o n)
    (cond ((assoc-ref (.locals info) o)
           =>
           (lambda (local) (wrap-as (as info 'local-add (local:id local) n))))
          ((assoc-ref (.statics info) o)
           =>
           (lambda (global)
             (let* ((size (->size global info))
                    (reg-size (->size "*" info))
                    (size (if (= size reg-size) 0 size)))
               (case size
                 ((0) (wrap-as (as info 'label-mem-add `(#:address ,o) n)))
                 ((1) (wrap-as (as info 'byte-label-mem-add `(#:address ,o) n)))
                 ((2) (wrap-as (as info 'word-label-mem-add `(#:address ,o) n)))
                 ((4) (wrap-as (as info 'long-mem-add `(#:address ,o) n)))
                 (else (as info 'label-mem-add `(#:address ,o) n))))))
          ((assoc-ref (filter (negate static-global?) (.globals info)) o)
           =>
           (lambda (global)
             (let* ((size (->size global info))
                    (reg-size (->size "*" info))
                    (size (if (= size reg-size) 0 size)))
               (case size
                 ((0) (wrap-as (as info 'label-mem-add `(#:address ,o) n)))
                 ((1) (wrap-as (as info 'byte-label-mem-add `(#:address ,o) n)))
                 ((2) (wrap-as (as info 'word-label-mem-add `(#:address ,o) n)))
                 ((4) (wrap-as (as info 'long-mem-add `(#:address ,o) n)))
                 (else (as info 'label-mem-add `(#:address ,o) n)))))))))

(define (make-comment o)
  (wrap-as `((#:comment ,o))))

(define (ast->comment o)
  (if mes-or-reproducible? '()
      (let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
             ;; Nyacc fixups
             (source (string-substitute source "\\" "\\\\"))
             (source (string-substitute source "'\\'" "'\\\\'"))
             (source (string-substitute source "'\"'" "'\\\"'"))
             (source (string-substitute source "'''" "'\\''"))
             (source (string-substitute source "\n" "\\n"))
             (source (string-substitute source "\r" "\\r")))
        (make-comment source))))

(define (r*n info n)
  (case n
    ((1) info)
    ((2) (append-text info (wrap-as (as info 'r+r))))
    ((3) (let* ((info (allocate-register info))
                (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                         (as info 'r+r)
                                                         (as info 'r0+r1)))))
                (info (free-register info)))
           info))
    ((4) (append-text info (wrap-as (as info 'shl-r 2))))
    ((5) (let* ((info (allocate-register info))
                (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                         (as info 'r+r)
                                                         (as info 'r+r)
                                                         (as info 'r0+r1)))))
                (info (free-register info)))
           info))
    ((6) (let* ((info (allocate-register info))
                (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                         (as info 'r+r)
                                                         (as info 'r0+r1)))))
                (info (free-register info))
                (info (append-text info (wrap-as (append (as info 'shl-r 1))))))
           info))
    ((8) (append-text info (wrap-as (append (as info 'shl-r 3)))))
    ((10) (let* ((info (allocate-register info))
                 (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                          (as info 'r+r)
                                                          (as info 'r+r)
                                                          (as info 'r0+r1)))))
                 (info (free-register info))
                 (info (append-text info (wrap-as (append (as info 'shl-r 1))))))
            info))
    ((12) (let* ((info (allocate-register info))
                 (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                          (as info 'r+r)
                                                          (as info 'r0+r1)))))
                 (info (free-register info))
                 (info (append-text info (wrap-as (append (as info 'shl-r 2))))))
            info))
    ((16) (append-text info (wrap-as (as info 'shl-r 4))))
    ((20) (let* ((info (allocate-register info))
                 (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                          (as info 'r+r)
                                                          (as info 'r+r)
                                                          (as info 'r0+r1)))))
                 (info (free-register info))
                 (info (append-text info (wrap-as (append (as info 'shl-r 2))))))
            info))
    ((24) (let* ((info (allocate-register info))
                 (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                          (as info 'r+r)
                                                          (as info 'r0+r1)))))
                 (info (free-register info))
                 (info (append-text info (wrap-as (append (as info 'shl-r 3))))))
            info))

    (else (let* ((info (allocate-register info))
                 (info (append-text info (wrap-as (as info 'value->r n))))
                 (info (append-text info (wrap-as (as info 'r0*r1))))
                 (info (free-register info)))
            info))))

(define (allocate-register info)
  (let ((registers (.registers info))
        (allocated (.allocated info)))
    (if (< (length allocated) (max-registers info))
        (clone info #:allocated (cons (car registers) (.allocated info)) #:registers (cdr registers))
        (let* ((info (clone info #:pushed (1+ (.pushed info))))
               (info (append-text info (wrap-as (append (as info 'push-r0)
                                                        (as info 'r1->r0))))))
          info))))

(define (free-register info)
  (let ((allocated (.allocated info))
        (pushed (.pushed info)))
    (if (zero? pushed)
        (clone info #:allocated (cdr allocated) #:registers (cons (car allocated) (.registers info)))
        (let* ((info (clone info #:pushed (1- pushed)))
               (info (append-text info (wrap-as (append (as info 'r0->r1)
                                                        (as info 'pop-r0))))))
          info))))

(define (push-register r info)
  (append-text info (wrap-as (as info 'push-register r))))

(define (pop-register r info)
  (append-text info (wrap-as (as info 'pop-register r))))

(define (r0->r1-mem*n- info n size)
  (let ((reg-size (->size "*" info)))
    (wrap-as
     (cond
      ((= n 1) (as info 'byte-r0->r1-mem))
      ((= n 2) (cond ((= size 1) (append (as info 'byte-r0->r1-mem)
                                         (as info 'r+value 1)
                                         (as info 'value->r0 0)
                                         (as info 'byte-r0->r1-mem)))
                     (else (as info 'word-r0->r1-mem))))
      ((= n 4) (as info 'long-r0->r1-mem))
      ((and (= n 8) (or (= reg-size 8)
                        (= size 4)))
       (cond ((= size 4) (append (as info 'long-r0->r1-mem)
                                 (as info 'r+value 4)
                                 (as info 'value->r0 0)
                                 (as info 'long-r0->r1-mem)))
             ((and (= size 8) (= reg-size 8)) (as info 'quad-r0->r1-mem))
             (else (error "r0->r1-mem*n-: not supported"))))
      (else (let loop ((i 0))
              (if (>= i n) '()
                  (case (- n i)
                    ((1) (as info 'byte-r0-mem->r1-mem))
                    ((2) (as info 'word-r0-mem->r1-mem))
                    ((3) (append (as info 'word-r0-mem->r1-mem)
                                 (as info 'r+value 2)
                                 (as info 'r0+value 2)
                                 (loop (+ i 2))))
                    ((4) (append (as info 'long-r0-mem->r1-mem)))
                    (else (append (as info 'r0-mem->r1-mem)
                                  (as info 'r+value reg-size)
                                  (as info 'r0+value reg-size)
                                  (loop (+ i reg-size))))))))))))

(define (r0->r1-mem*n info n size)
  (append-text info (r0->r1-mem*n- info n size)))

(define (expr->register* o info)
  (pmatch o
    ((p-expr (ident ,name))
     (let ((info (allocate-register info)))
       (append-text info ((ident-address->r info) name))))

    ((de-ref ,expr)
     (expr->register expr info))

    ((d-sel (ident ,field) ,struct)
     (let* ((type (ast->basic-type struct info))
            (offset (field-offset info type field))
            (info (expr->register* struct info)))
       (append-text info (wrap-as (as info 'r+value offset)))))

    ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
     (let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info))
            (offset (field-offset info type field))
            (info (expr->register `(fctn-call (p-expr (ident ,function)) ,@rest) info)))
       (append-text info (wrap-as (as info 'r+value offset)))))

    ((i-sel (ident ,field) ,struct)
     (let* ((type (ast->basic-type struct info))
            (offset (field-offset info type field))
            (info (expr->register* struct info))
            (type (ast->type struct info)))
       (append-text info (append (if (c-array? type) '()
                                     (wrap-as (as info 'mem->r)))
                                 (wrap-as (as info 'r+value offset))))))

    ((array-ref ,index ,array)
     (let* ((info (expr->register index info))
            (size (ast->size o info))
            (info (r*n info size))
            (info (expr->register array info))
            (info (append-text info (wrap-as (as info 'r0+r1))))
            (info (free-register info)))
       info))

    ((cast ,type ,expr)
     (expr->register `(ref-to ,expr) info))

    ((add ,a ,b)
     (let* ((rank (expr->rank info a))
            (rank-b (expr->rank info b))
            (type (ast->basic-type a info))
            (struct? (structured-type? type))
            (reg-size (->size "*" info))
            (size (cond ((= rank 1) (ast-type->size info a))
                        ((> rank 1) reg-size)
                        ((and struct? (= rank 2)) reg-size)
                        (else 1))))
       (if (or (= size 1)) ((binop->r* info) a b 'r0+r1)
           (let* ((info (expr->register b info))
                  (info (allocate-register info))
                  (info (append-text info (wrap-as (append (as info 'value->r size)
                                                           (as info 'r0*r1)))))
                  (info (free-register info))
                  (info (expr->register* a info))
                  (info (append-text info (wrap-as (as info 'r0+r1))))
                  (info (free-register info)))
             info))))

    ((sub ,a ,b)
     (let* ((rank (expr->rank info a))
            (rank-b (expr->rank info b))
            (type (ast->basic-type a info))
            (struct? (structured-type? type))
            (size (->size type info))
            (reg-size (->size "*" info))
            (size  (cond ((= rank 1) size)
                         ((> rank 1) reg-size)
                         ((and struct? (= rank 2)) reg-size)
                         (else 1))))
       (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
           (let ((info ((binop->r* info) a b 'r0-r1)))
             (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
                 ;; FIXME: c&p 1158
                 (let* ((info (allocate-register info))
                        (info (append-text info (wrap-as (append
                                                          (as info 'value->r size)
                                                          (as info 'swap-r0-r1)
                                                          (as info 'r0/r1 #f)))))
                        (info (append-text info (wrap-as (append (as info 'swap-r0-r1)))))
                        (free-register info))
                   info)))
           (let* ((info (expr->register* b info))
                  (info (allocate-register info))
                  (info (append-text info (wrap-as (append (as info 'value->r size)
                                                           (as info 'r0*r1)))))
                  (info (free-register info))
                  (info (expr->register* a info))
                  (info (append-text info (wrap-as (append (as info 'swap-r0-r1)))))
                  (info (append-text info (wrap-as (as info 'r0-r1))))
                  (info (free-register info)))
             info))))

    ((post-dec ,expr)
     (let* ((info (expr->register* expr info))
            (post (clone info #:text '()))
            (post (allocate-register post))
            (post (append-text post (wrap-as (as post 'r0->r1))))
            (rank (expr->rank post expr))
            (reg-size (->size "*" info))
            (size (cond ((= rank 1) (ast-type->size post expr))
                        ((> rank 1) reg-size)
                        (else 1)))
            (post ((expr-add post) expr (- size))))
       (clone info #:post (.text post))))

    ((post-inc ,expr)
     (let* ((info (expr->register* expr info))
            (post (clone info #:text '()))
            (post (allocate-register post))
            (post (append-text post (wrap-as (as post 'r0->r1))))
            (rank (expr->rank post expr))
            (reg-size (->size "*" info))
            (size (cond ((= rank 1) (ast-type->size post expr))
                        ((> rank 1) reg-size)
                        (else 1)))
            (post ((expr-add post) expr size)))
       (clone info #:post (.text post))))

    ((pre-dec ,expr)
     (let* ((rank (expr->rank info expr))
            (reg-size (->size "*" info))
            (size (cond ((= rank 1) (ast-type->size info expr))
                        ((> rank 1) reg-size)
                        (else 1)))
            (info ((expr-add info) expr (- size)))
            (info (append (expr->register* expr info))))
       info))

    ((pre-inc ,expr)
     (let* ((rank (expr->rank info expr))
            (reg-size (->size "*" info))
            (size (cond ((= rank 1) (ast-type->size info expr))
                        ((> rank 1) reg-size)
                        (else 1)))
            (info ((expr-add info) expr size))
            (info (append (expr->register* expr info))))
       info))

    (_ (error "expr->register*: not supported: " o))))

(define (expr-add info)
  (lambda (o n)
    (let* ((info (expr->register* o info))
           (size (ast->size o info))
           (reg-size (->size "*" info))
           (size (if (= size reg-size) 0 size))
           (info (append-text info (wrap-as (append (as info
                                                        (case size
                                                          ((0) 'r-mem-add)
                                                          ((1) 'r-byte-mem-add)
                                                          ((2) 'r-word-mem-add)
                                                          ((4) 'r-long-mem-add)) n))))))
      (free-register info))))

(define (expr->register o info)
  (let* ((locals (.locals info))
         (text (.text info))
         (globals (.globals info))
         (r-size (->size "*" info)))

    (define (helper)
      (pmatch o
        ((expr) info)

        ((comma-expr)
         (allocate-register info))

        ((comma-expr ,a . ,rest)
         (let* ((info (expr->register a info))
                (info (free-register info)))
           (expr->register `(comma-expr ,@rest) info)))

        ((p-expr (string ,string))
         (let* ((globals ((globals:add-string globals) string))
                (info (clone info #:globals globals))
                (info (allocate-register info)))
           (append-text info (wrap-as (as info 'label->r `(#:string ,string))))))

        ((p-expr (string . ,strings))
         (let* ((string (apply string-append strings))
                (globals ((globals:add-string globals) string))
                (info (clone info #:globals globals))
                (info (allocate-register info)))
           (append-text info (wrap-as (as info 'label->r `(#:string ,string))))))

        ((p-expr (fixed ,value))
         (let* ((value (cstring->int value))
                (reg-size (->size "*" info))
                (info (allocate-register info))
                (info (append-text info (wrap-as (as info 'value->r value)))))
           (if (or #t (> value 0) (= reg-size 4)) info
               (append-text info (wrap-as (as info 'long-signed-r))))))

        ((p-expr (float ,value))
         (let ((value (cstring->float value))
               (info (allocate-register info)))
           (append-text info (wrap-as (as info 'value->r value)))))

        ((neg (p-expr (fixed ,value)))
         (let* ((value (- (cstring->int value)))
                (info (allocate-register info))
                (info (append-text info (append (wrap-as (as info 'value->r value)))))
                (reg-size (->size "*" info)))
           (if (or #t (> value 0) (= reg-size 4)) info
               (append-text info (wrap-as (as info 'long-signed-r))))))

        ((p-expr (char ,char))
         (let ((char (char->integer (car (string->list char))))
               (info (allocate-register info)))
           (append-text info (wrap-as (as info 'value->r char)))))

        (,char (guard (char? char))
               (let ((info (allocate-register info)))
                 (append-text info (wrap-as (as info 'value->r (char->integer char))))))

        ((p-expr (ident ,name))
         (let ((info (allocate-register info)))
           (append-text info ((ident->r info) name))))

        ((initzer ,initzer)
         (expr->register initzer info))

        (((initzer ,initzer))
         (expr->register initzer info))

        ;; offsetoff
        ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
         (let* ((type (ast->basic-type struct info))
                (offset (field-offset info type field))
                (base (cstring->int base))
                (info (allocate-register info)))
           (append-text info (wrap-as (as info 'value->r (+ base offset))))))

        ;; &foo
        ((ref-to (p-expr (ident ,name)))
         (let ((info (allocate-register info)))
           (append-text info ((ident-address->r info) name))))

        ;; &*foo
        ((ref-to (de-ref ,expr))
         (expr->register expr info))

        ((ref-to ,expr)
         (expr->register* expr info))

        ((sizeof-expr ,expr)
         (let ((info (allocate-register info)))
           (append-text info (wrap-as (as info 'value->r (ast->size expr info))))))

        ((sizeof-type ,type)
         (let ((info (allocate-register info)))
           (append-text info (wrap-as (as info 'value->r (ast->size type info))))))

        ((array-ref ,index ,array)
         (let* ((info (expr->register* o info))
                (type (ast->type o info)))
           (append-text info (mem->r type info))))

        ((d-sel ,field ,struct)
         (let* ((info (expr->register* o info))
                (info (append-text info (ast->comment o)))
                (type (ast->type o info))
                (size (->size type info))
                (array? (c-array? type)))
           (if array? info
               (append-text info (mem->r type info)))))

        ((i-sel ,field ,struct)
         (let* ((info (expr->register* o info))
                (info (append-text info (ast->comment o)))
                (type (ast->type o info))
                (size (->size type info))
                (array? (c-array? type)))
           (if array? info
               (append-text info (mem->r type info)))))

        ((de-ref ,expr)
         (let* ((info (expr->register expr info))
                (type (ast->type o info)))
           (append-text info (mem->r type info))))

        ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
         (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
                                   (append-text info (wrap-as (asm->m1 arg0))))
             (let* ((info (append-text info (ast->comment o)))
                    (info (allocate-register info))
                    (allocated (.allocated info))
                    (pushed (.pushed info))
                    (registers (.registers info))
                    (info (fold push-register info (cdr allocated)))
                    (reg-size (->size "*" info))
                    (info (if (cc-amd? info) (fold expr->arg info expr-list (iota (length expr-list)))
                              (fold-right expr->arg info expr-list (reverse (iota (length expr-list))))))
                    (info (clone info #:allocated '() #:pushed 0 #:registers (append (reverse allocated) registers)))
                    (n (length expr-list))
                    (info (if (not (assoc-ref locals name))
                              (begin
                                (when (and (not (assoc name (.functions info)))
                                           (not (assoc name globals))
                                           (not (equal? name (.function info))))
                                  (format (current-error-port) "warning: undeclared function: ~a\n" name))
                                (append-text info (wrap-as (as info 'call-label name n))))
                              (let* ((info (expr->register `(p-expr (ident ,name)) info))
                                     (info (append-text info (wrap-as (as info 'call-r n)))))
                                info)))
                    (info (clone info #:allocated allocated #:pushed pushed #:registers registers))
                    (info (if (null? (cdr allocated)) info
                              (append-text info (wrap-as (as info 'return->r)))))
                    (info (fold-right pop-register info (cdr allocated))))
               info)))

        ((fctn-call ,function (expr-list . ,expr-list))
         (let* ((info (append-text info (ast->comment o)))
                (info (allocate-register info))
                (allocated (.allocated info))
                (pushed (.pushed info))
                (registers (.registers info))
                (info (fold push-register info (cdr allocated)))
                (reg-size (->size "*" info))
                (info (if (cc-amd? info) (fold expr->arg info expr-list (iota (length expr-list)))
                          (fold-right expr->arg info expr-list (reverse (iota (length expr-list))))))
                (info (fold (lambda (x info) (free-register info)) info (.allocated info)))
                (n (length expr-list))
                (function (pmatch function
                            ((de-ref ,function) function)
                            (_ function)))
                (info (expr->register function info))
                (info (append-text info (wrap-as (as info 'call-r n))))
                (info (free-register info))
                (info (clone info #:allocated allocated #:pushed pushed #:registers registers))
                (info (if (null? (cdr allocated)) info
                          (append-text info (wrap-as (as info 'return->r)))))
                (info (fold-right pop-register info (cdr allocated))))
           info))

        ((cond-expr ,test ,then ,else)
         (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
                (here (number->string (length text)))
                (label (string-append "_" (.function info) "_" here "_"))
                (else-label (string-append label "else"))
                (break-label (string-append label "break"))
                (info ((test-jump-label->info info else-label) test))
                (info (expr->register then info))
                (info (free-register info))
                (info (append-text info (wrap-as (as info 'jump break-label))))
                (info (append-text info (wrap-as `((#:label ,else-label)))))
                (info (expr->register else info))
                (info (free-register info))
                (info (append-text info (wrap-as `((#:label ,break-label)))))
                (info (allocate-register info)))
           info))

        ((post-inc ,expr)
         (let* ((info (append (expr->register expr info)))
                (rank (expr->rank info expr))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info expr))
                            ((> rank 1) reg-size)
                            (else 1)))
                (info ((expr-add info) expr size)))
           info))

        ((post-dec ,expr)
         (let* ((info (append (expr->register expr info)))
                (rank (expr->rank info expr))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info expr))
                            ((> rank 1) reg-size)
                            (else 1)))
                (info ((expr-add info) expr (- size))))
           info))

        ((pre-inc ,expr)
         (let* ((rank (expr->rank info expr))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info expr))
                            ((> rank 1) reg-size)
                            (else 1)))
                (info ((expr-add info) expr size))
                (info (append (expr->register expr info))))
           info))

        ((pre-dec ,expr)
         (let* ((rank (expr->rank info expr))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info expr))
                            ((> rank 1) reg-size)
                            (else 1)))
                (info ((expr-add info) expr (- size)))
                (info (append (expr->register expr info))))
           info))



        ((add ,a (p-expr (fixed ,value)))
         (let* ((rank (expr->rank info a))
                (type (ast->basic-type a info))
                (struct? (structured-type? type))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info a))
                            ((> rank 1) reg-size)
                            ((and struct? (= rank 2)) reg-size)
                            (else 1)))
                (info (expr->register a info))
                (value (cstring->int value))
                (value (* size value)))
           (append-text info (wrap-as (as info 'r+value value)))))

        ((add ,a ,b)
         (let* ((rank (expr->rank info a))
                (rank-b (expr->rank info b))
                (type (ast->basic-type a info))
                (struct? (structured-type? type))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info a))
                            ((> rank 1) reg-size)
                            ((and struct? (= rank 2)) reg-size)
                            (else 1))))
           (if (or (= size 1)) ((binop->r info) a b 'r0+r1)
               (let* ((info (expr->register b info))
                      (info (allocate-register info))
                      (info (append-text info (wrap-as (append (as info 'value->r size)
                                                               (as info 'r0*r1)))))
                      (info (free-register info))
                      (info (expr->register a info))
                      (info (append-text info (wrap-as (as info 'r0+r1))))
                      (info (free-register info)))
                 info))))

        ((sub ,a (p-expr (fixed ,value)))
         (let* ((rank (expr->rank info a))
                (type (ast->basic-type a info))
                (struct? (structured-type? type))
                (size (->size type info))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) size)
                            ((> rank 1) reg-size)
                            ((and struct? (= rank 2)) reg-size)
                            (else 1)))
                (info (expr->register a info))
                (value (cstring->int value))
                (value (* size value)))
           (append-text info (wrap-as (as info 'r+value (- value))))))

        ((sub ,a ,b)
         (let* ((rank (expr->rank info a))
                (rank-b (expr->rank info b))
                (type (ast->basic-type a info))
                (struct? (structured-type? type))
                (size (->size type info))
                (reg-size (->size "*" info))
                (size  (cond ((= rank 1) size)
                             ((> rank 1) reg-size)
                             ((and struct? (= rank 2)) reg-size)
                             (else 1))))

           (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
               (let ((info ((binop->r info) a b 'r0-r1)))
                 (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
                     ;; FIXME: c&p 792
                     (let* ((info (allocate-register info))
                            (info (append-text info (wrap-as (append (as info 'value->r size)
                                                                     (as info 'r0/r1 #f)))))
                            (info (free-register info)))
                       info)))
               (let* ((info (expr->register b info))
                      (info (allocate-register info))
                      (info (append-text info (wrap-as (append (as info 'value->r size)
                                                               (as info 'r0*r1)))))
                      (info (free-register info))
                      (info (expr->register a info))
                      (info (append-text info (wrap-as (append (as info 'swap-r0-r1)))))
                      (info (append-text info (wrap-as (as info 'r0-r1))))
                      (info (free-register info)))
                 info))))

        ((bitwise-and ,a ,b) ((binop->r info) a b 'r0-and-r1))
        ((bitwise-not ,expr)
         (let ((info (expr->register expr info)))
           (append-text info (wrap-as (as info 'not-r)))))
        ((bitwise-or ,a ,b) ((binop->r info) a b 'r0-or-r1))
        ((bitwise-xor ,a ,b) ((binop->r info) a b 'r0-xor-r1))
        ((lshift ,a ,b)
         (let* ((type-a (ast->type a info))
                (default (get-type "default" info))
                (type (if (> (->size type-a info) (->size default info)) type-a
                             default))
                (info ((binop->r info) a b 'r0<<r1)))
           (append-text info (convert-r0 info type))))
        ((rshift ,a ,b)
         (let* ((type-a (ast->type a info))
                (default (get-type "default" info))
                (type (if (> (->size type-a info) (->size default info)) type-a
                             default))
                (info ((binop->r info) a b (if (signed? type) 'r0>>r1-signed 'r0>>r1))))
           (append-text info (convert-r0 info type))))
        ((div ,a ,b)
         ((binop->r info) a b 'r0/r1
          (signed? (ast->type a info))))
        ((mod ,a ,b) ((binop->r info) a b 'r0%r1
                      (signed? (ast->type a info))))
        ((mul ,a ,b) ((binop->r info) a b 'r0*r1))

        ((not ,expr)
         (let* ((info (expr->register expr info))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (append-text info (wrap-as (as info 'r-negate)))))
           (append-text info (wrap-as (as info 'test-r))))) ;; hmm, use ast->info?

        ((pos ,expr)
         (expr->register expr info))

        ((neg ,expr)
         (let* ((info (expr->register expr info))
                (info (allocate-register info))
                (info (append-text info (append (wrap-as (as info 'value->r 0))
                                                (wrap-as (as info 'swap-r0-r1))
                                                (wrap-as (as info 'r0-r1)))))
                (info (free-register info)))
           info))

        ((eq ,a ,b) (let ((info ((binop->r info) a b 'r0-cmp-r1)))
                      (append-text info (wrap-as (as info 'zf->r)))))

        ((ge ,a ,b)
         (let* ((type-a (ast->type a info))
                (type-b (ast->type b info))
                (info ((binop->r info) a b 'r0-cmp-r1))
                (test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'ae?->r 'ge?->r))
                (info (append-text info (wrap-as (as info test->r))))
                (info (append-text info (wrap-as (as info 'test-r)))))
           info))

        ((gt ,a ,b)
         (let* ((type-a (ast->type a info))
                (type-b (ast->type b info))
                (info ((binop->r info) a b 'r0-cmp-r1))
                (test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'a?->r 'g?->r))
                (info (append-text info (wrap-as (as info test->r))))
                (info (append-text info (wrap-as (as info 'test-r)))))
           info))

        ((ne ,a ,b) (let* ((info ((binop->r info) a b 'r0-r1))
                           (info (append-text info (wrap-as (as info 'test-r))))
                           (info (append-text info (wrap-as (as info 'xor-zf))))
                           (info (append-text info (wrap-as (as info 'zf->r)))))
                      info))

        ((le ,a ,b)
         (let* ((type-a (ast->type a info))
                (type-b (ast->type b info))
                (info ((binop->r info) a b 'r0-cmp-r1))
                (test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'be?->r 'le?->r))
                (info (append-text info (wrap-as (as info test->r))))
                (info (append-text info (wrap-as (as info 'test-r)))))
           info))

        ((lt ,a ,b)
         (let* ((type-a (ast->type a info))
                (type-b (ast->type b info))
                (info ((binop->r info) a b 'r0-cmp-r1))
                (test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'b?->r 'l?->r))
                (info (append-text info (wrap-as (as info test->r))))
                (info (append-text info (wrap-as (as info 'test-r)))))
           info))

        ((or ,a ,b)
         (let* ((info (expr->register a info))
                (here (number->string (length (.text info))))
                (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b"))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (append-text info (wrap-as (as info 'jump-nz skip-b-label))))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (free-register info))
                (info (expr->register b info))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
           info))

        ((and ,a ,b)
         (let* ((info (expr->register a info))
                (here (number->string (length (.text info))))
                (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b"))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (append-text info (wrap-as (as info 'jump-z skip-b-label))))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (free-register info))
                (info (expr->register b info))
                (info (append-text info (wrap-as (as info 'test-r))))
                (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
           info))

        ((cast ,type ,expr)
         (let ((info (expr->register expr info))
               (type (ast->type o info)))
           (append-text info (convert-r0 info type))))

        ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
         (let* ((info (expr->register `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
                (type (ident->type info name))
                (rank (ident->rank info name))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info `(p-expr (ident ,name))))
                            ((> rank 1) reg-size)
                            (else 1))))
           (append-text info ((ident-add info) name size))))

        ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
         (let* ((info (expr->register `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
                (type (ident->type info name))
                (rank (ident->rank info name))
                (reg-size (->size "*" info))
                (size (cond ((= rank 1) (ast-type->size info `(p-expr (ident ,name))))
                            ((> rank 1) reg-size)
                            (else 1))))
           (append-text info ((ident-add info) name (- size)))))

        ((assn-expr ,a (op ,op) ,b)
         (let* ((info (append-text info (ast->comment o)))
                (type (ast->type a info))
                (rank (->rank type))
                (type-b (ast->type b info))
                (rank-b (->rank type-b))
                (reg-size (->size "*" info))
                (size (if (zero? rank) (->size type info) reg-size))
                (size-b (if (zero? rank-b) (->size type-b info) reg-size))
                (info (expr->register b info))
                (info (if (equal? op "=") info
                          (let* ((struct? (structured-type? type))
                                 (size (cond ((= rank 1) (ast-type->size info a))
                                             ((> rank 1) reg-size)
                                             ((and struct? (= rank 2)) reg-size)
                                             (else 1)))
                                 (info (if (or (= size 1) (= rank-b 1)) info
                                           (let* ((info (allocate-register info))
                                                  (info (append-text info (wrap-as (as info 'value->r size))))
                                                  (info (append-text info (wrap-as (as info 'r0*r1))))
                                                  (info (free-register info)))
                                             info)))
                                 (info (expr->register a info))
                                 (info (append-text info (wrap-as (as info 'swap-r0-r1))))
                                 (signed? (signed? type))
                                 (info (append-text info (cond ((equal? op "+=") (wrap-as (as info 'r0+r1)))
                                                               ((equal? op "-=") (wrap-as (as info 'r0-r1)))
                                                               ((equal? op "*=") (wrap-as (as info 'r0*r1)))
                                                               ((equal? op "/=") (wrap-as (as info 'r0/r1 signed?)))
                                                               ((equal? op "%=") (wrap-as (as info 'r0%r1 signed?)))
                                                               ((equal? op "&=") (wrap-as (as info 'r0-and-r1)))
                                                               ((equal? op "|=") (wrap-as (as info 'r0-or-r1)))
                                                               ((equal? op "^=") (wrap-as (as info 'r0-xor-r1)))
                                                               ((equal? op ">>=") (wrap-as (as info (if signed? 'r0>>r1-signed 'r0>>r1))))
                                                               ((equal? op "<<=") (wrap-as (as info 'r0<<r1)))
                                                               (else (error (format #f "mescc: op ~a not supported: ~a\n" op o))))))
                                 (info (free-register info)))
                            (cond ((not (and (= rank 1) (= rank-b 1))) info)
                                  ((equal? op "-=") (let* ((info (allocate-register info))
                                                           (info (append-text info (wrap-as (append (as info 'value->r size)
                                                                                                    (as info 'r0/r1 signed?)))))
                                                           (info (free-register info)))
                                                      info))
                                  (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*) " op type (ast->basic-type b info)))))))))
           (when (and (equal? op "=")
                      (not (= size size-b))
                      (not (and (or (= size 1) (= size 2))
                                (or (= size-b 2) (= size-b 4) (= size-b reg-size))))
                      (not (and (= size 2)
                                (= size-b 4)))
                      (not (and (= size 2)
                                (= size-b reg-size)))
                      (not (and (= size reg-size)
                                (or (= size-b 1) (= size-b 2) (= size-b 4)))))
             (when (getenv ("MESCC_DEBUG"))
               (format (current-error-port) "WARNING assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
               (format (current-error-port) "   size[~a]:~a != size[~a]:~a\n"  rank size rank-b size-b)))
           (pmatch a
             ((p-expr (ident ,name))
              (if (or (<= size r-size)
                      (<= size-b r-size)) (append-text info ((r->ident info) name))
                      (let* ((info (expr->register* a info))
                             (info (r0->r1-mem*n info size size-b)))
                        (free-register info))))

             (_ (let* ((info (expr->register* a info))
                       (reg-size (->size "*" info))
                       (info (if (not (bit-field? type)) info
                                 (let* ((bit (bit-field:bit type))
                                        (bits (bit-field:bits type))
                                        (set-mask (- (ash bits 1) 1))
                                        (shifted-set-mask (ash set-mask bit))
                                        (clear-mask (logxor shifted-set-mask
                                                            (if (= reg-size 4)
                                                                #b11111111111111111111111111111111
                                                                #b1111111111111111111111111111111111111111111111111111111111111111)))

                                        (info (append-text info (wrap-as (as info 'swap-r0-r1))))
                                        (info (allocate-register info))
                                        (info (append-text info (wrap-as (as info 'r2->r0))))
                                        (info (append-text info (wrap-as (as info 'swap-r0-r1))))
                                        (info (append-text info (wrap-as (as info 'mem->r))))
                                        (info (append-text info (wrap-as (as info 'r-and clear-mask))))
                                        (info (append-text info (wrap-as (as info 'swap-r0-r1))))
                                        (info (append-text info (wrap-as (as info 'r-and set-mask))))
                                        (info (append-text info (wrap-as (as info 'shl-r bit))))
                                        (info (append-text info (wrap-as (as info 'r0-or-r1))))
                                        (info (free-register info))
                                        (info (append-text info (wrap-as (as info 'swap-r0-r1)))))
                                   info)))
                       (info (r0->r1-mem*n info
                                           (min size (max reg-size size-b))
                                           (min size (max reg-size size-b))))
                       (info (free-register info)))
                  info)))))
        (_ (error "expr->register: not supported: " o))))

    (let ((info (helper)))
      (if (null? (.post info)) info
          (append-text (clone info #:post '()) (.post info))))))

(define (mem->r type info)
  (let* ((size (->size type info))
         (reg-size (->size "*" info))
         (size (if (= size reg-size) 0 size)))
    (case size
      ((0) (wrap-as (as info 'mem->r)))
      ((1) (append (wrap-as (as info 'byte-mem->r)) (convert-r0 info type)))
      ((2) (append (wrap-as (as info 'word-mem->r)) (convert-r0 info type)))
      ((4) (append (wrap-as (as info 'long-mem->r)) (convert-r0 info type)))
      (else '()))))

(define (convert-r0 info type)
  (if (not (type? type)) '()
      (let ((sign (signed? type))
            (size (->size type info))
            (reg-size (->size "*" info)))
        (cond ((and (= size 1) sign)
               (wrap-as (as info 'byte-signed-r)))
              ((= size 1)
               (wrap-as (as info 'byte-r))
               ;;(wrap-as (as info 'byte-signed-r))
               )
              ((and (= size 2) sign)
               (wrap-as (as info 'word-signed-r)))
              ((= size 2)
               (wrap-as (as info 'word-r))
               ;;(wrap-as (as info 'word-signed-r))
               )
              ((and (> reg-size 4) (= size 4) sign)
               (wrap-as (as info 'long-signed-r)))
              ((and (> reg-size 4) (= size 4))
               ;; for 17-unsigned-le
               (wrap-as (as info 'long-signed-r))  ; huh, why not long-r?
               ;; for a0-call-trunc-int
               ;;(wrap-as (as info 'long-r))
               )
              (else '())))))

(define (binop->r info)
  (lambda (a b c . rest)
    (let* ((info (expr->register a info))
           (info (expr->register b info))
           (info (append-text info (wrap-as (apply as info (cons c rest))))))
      (free-register info))))

(define (binop->r* info)
  (lambda (a b c)
    (let* ((info (expr->register* a info))
           (info (expr->register b info))
           (info (append-text info (wrap-as (as info c)))))
      (free-register info))))

(define (wrap-as o . annotation)
  `(,@annotation ,o))

(define (comment? o)
  (and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))

(define (test-jump-label->info info label)
  (define (jump type . test)
    (lambda (o)
      (let* ((info (expr->register o info))
             (info (append-text info (make-comment "jmp test LABEL")))
             (jump-text (wrap-as (as info type label)))
             (info (append-text info (append (if (null? test) '() ((car test) info))
                                             jump-text)))
             (info (free-register info)))
        info)))
  (lambda (o)
    (pmatch o
      ((expr) info)
      ((le ,a ,b) ((jump 'jump-z) o))
      ((lt ,a ,b) ((jump 'jump-z) o))
      ((ge ,a ,b) ((jump 'jump-z) o))
      ((gt ,a ,b) ((jump 'jump-z) o))
      ((ne ,a ,b) ((jump 'jump-nz) o))
      ((eq ,a ,b) ((jump 'jump-nz) o))
      ((not _) ((jump 'jump-z) o))

      ((and ,a ,b)
       (let* ((info ((test-jump-label->info info label) a))
              (info ((test-jump-label->info info label) b)))
         info))

      ((or ,a ,b)
       (let* ((here (number->string (length (if mes-or-reproducible? (.text info)
                                                (filter (negate comment?) (.text info))))))
              (skip-b-label (string-append label "_skip_b_" here))
              (b-label (string-append label "_b_" here))
              (info ((test-jump-label->info info b-label) a))
              (info (append-text info (wrap-as (as info 'jump skip-b-label))))
              (info (append-text info (wrap-as `((#:label ,b-label)))))
              (info ((test-jump-label->info info label) b))
              (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
         info))

      ((array-ref ,index ,expr) (let* ((rank (expr->rank info expr))
                                       (reg-size (->size "*" info))
                                       (size (if (= rank 1) (ast-type->size info expr)
                                                 reg-size)))
                                  ((jump (if (= size 1) 'jump-byte-z
                                             'jump-z)
                                         (lambda (info) (wrap-as (as info 'r-zero?)))) o)))

      ((de-ref ,expr) (let* ((rank (expr->rank info expr))
                             (r-size (->size "*" info))
                             (size (if (= rank 1) (ast-type->size info expr)
                                       r-size)))
                        ((jump (if (= size 1) 'jump-byte-z
                                   'jump-z)
                               (lambda (info) (wrap-as (as info 'r-zero?)))) o)))

      ((assn-expr (p-expr (ident ,name)) ,op ,expr)
       ((jump 'jump-z
              (lambda (info)
                (append ((ident->r info) name)
                        (wrap-as (as info 'r-zero?))))) o))

      (_ ((jump 'jump-z (lambda (info) (wrap-as (as info 'r-zero?)))) o)))))

(define (cstring->int o)
  (let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
                 ((string-suffix? "UL" o) (string-drop-right o 2))
                 ((string-suffix? "U" o) (string-drop-right o 1))
                 ((string-suffix? "LL" o) (string-drop-right o 2))
                 ((string-suffix? "L" o) (string-drop-right o 1))
                 (else o))))
    (or (cond ((string-prefix? "0x" o) (string->number (string-drop o 2) 16))
              ((string-prefix? "0b" o) (string->number (string-drop o 2) 2))
              ((string-prefix? "0" o) (string->number o 8))
              (else (string->number o)))
        (error "cstring->int: not supported:" o))))

(define (cstring->float o)
  (or (string->number o)
      (error "cstring->float: not supported:" o)))

(define (try-expr->number info o)
  (pmatch o
    ((fixed ,a) (cstring->int a))
    ((p-expr ,expr) (expr->number info expr))
    ((pos ,a)
     (expr->number info a))
    ((neg ,a)
     (- (expr->number info a)))
    ((add ,a ,b)
     (+ (expr->number info a) (expr->number info b)))
    ((bitwise-and ,a ,b)
     (logand (expr->number info a) (expr->number info b)))
    ((bitwise-not ,a)
     (lognot (expr->number info a)))
    ((bitwise-or ,a ,b)
     (logior (expr->number info a) (expr->number info b)))
    ((div ,a ,b)
     (quotient (expr->number info a) (expr->number info b)))
    ((mul ,a ,b)
     (* (expr->number info a) (expr->number info b)))
    ((sub ,a ,b)
     (- (expr->number info a) (expr->number info b)))
    ((sizeof-type ,type)
     (->size (ast->type type info) info))
    ((sizeof-expr ,expr)
     (->size (ast->type expr info) info))
    ((lshift ,x ,y)
     (ash (expr->number info x) (expr->number info y)))
    ((rshift ,x ,y)
     (ash (expr->number info x) (- (expr->number info y))))
    ((p-expr (ident ,name))
     (let ((value (assoc-ref (.constants info) name)))
       (or value
           (error (format #f "expr->number: undeclared identifier: ~s\n" o)))))
    ((cast ,type ,expr) (expr->number info expr))
    ((cond-expr ,test ,then ,else)
     (if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
    (,string (guard (string? string)) (cstring->int string))
    ((ident ,name) (assoc-ref (.constants info) name))
    (_  #f)))

(define (expr->number info o)
  (or (try-expr->number info o)
      (error (format #f "expr->number: not supported: ~s\n" o))))

(define (p-expr->bool info o)
  (pmatch o
    ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b)))))

(define (struct-field info)
  (lambda (o)
    (pmatch o
      ((comp-decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))) (comp-declr-list . ,decls))
       (append-map (lambda (o)
                     ((struct-field info) `(comp-decl (decl-spec-list (type-spec "int")) (comp-declr-list ,o))))
                   decls))
      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ident ,name))))
       (list (cons name (ast->type type info))))
      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (ident ,name)))))
       (let ((rank (pointer->rank pointer)))
         (list (cons name (rank+= (ast->type type info) rank)))))
      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr ,pointer (ident ,name))) _))))
       (let ((rank (pointer->rank pointer)))
         (list (cons name (rank+= (ast->type type info) rank)))))
      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (array-of (ident ,name) ,count)))))
       (let ((rank (pointer->rank pointer))
             (count (expr->number info count)))
         (list (cons name (make-c-array (rank+= type rank) count)))))
      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
       (let ((count (expr->number info count)))
         (list (cons name (make-c-array (ast->type type info) count)))))
      ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
       (let ((fields (append-map (struct-field info) fields)))
         (list (cons 'struct (make-type 'struct (apply + (map (cut field:size <> info) fields)) fields)))))
      ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
       (let ((fields (append-map (struct-field info) fields)))
         (list (cons 'union (make-type 'union (apply + (map (cut field:size <> info) fields)) fields)))))
      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields))
       (let ((type (ast->type type info)))
         (list (cons 'bits (let loop ((o `((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields)) (bit 0))
                             (if (null? o) '()
                                 (let ((field (car o)))
                                   (pmatch field
                                     ((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits))))
                                      (let ((bits (cstring->int bits)))
                                        (cons (cons name (make-bit-field type bit bits))
                                              (loop (cdr o) (+ bit bits)))))
                                     (_ (error "struct-field: not supported:" field o))))))))))
      ((comp-decl (decl-spec-list ,type) (comp-declr-list . ,decls))
       (append-map (lambda (o)
                     ((struct-field info) `(comp-decl (decl-spec-list ,type) (comp-declr-list ,o))))
                   decls))
      (_ (error "struct-field: not supported: " o)))))

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

(define (ptr-declr->rank o)
  (pmatch o
    ((pointer) 1)
    ((pointer (pointer)) 2)
    ((pointer (pointer (pointer))) 3)
    (_ (error "ptr-declr->rank not supported: " o))))

(define (ast->info o info)
  (let ((functions (.functions info))
        (globals (.globals info))
        (locals (.locals info))
        (constants (.constants info))
        (types (.types info))
        (text (.text info)))
    (pmatch o
      (((trans-unit . _) . _) (ast-list->info o info))
      ((trans-unit . ,_) (ast-list->info _ info))
      ((fctn-defn . ,_) (fctn-defn->info _ info))

      ((cpp-stmt (define (name ,name) (repl ,value)))
       info)

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

      ((break)
       (let ((label (car (.break info))))
         (append-text info (wrap-as (as info 'jump label)))))

      ((continue)
       (let ((label (car (.continue info))))
         (append-text info (wrap-as (as info 'jump label)))))

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

      ((compd-stmt (block-item-list . ,_))
       (let* ((locals (.locals info))
              (info (ast-list->info _ info)))
         (clone info #:locals locals)))

      ((asm-expr ,gnuc (,null ,arg0 . string))
       (append-text info (wrap-as (asm->m1 arg0))))

      ;; Nyacc 0.90.2
      ((asm-expr ,gnuc (string ,arg0))
       (append-text info (wrap-as (asm->m1 arg0))))

      ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
       (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
                                 (append-text info (wrap-as (asm->m1 arg0))))
           (let* ((info (expr->register `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info))
                  (info (free-register info))
                  (info (append-text info (wrap-as (as info 'r-zero?)))))
             info)))

      ((if ,test ,then)
       (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
              (here (number->string (length text)))
              (label (string-append "_" (.function info) "_" here "_"))
              (break-label (string-append label "break"))
              (else-label (string-append label "else"))
              (info ((test-jump-label->info info break-label) test))
              (info (ast->info then info))
              (info (append-text info (wrap-as (as info 'jump break-label))))
              (info (append-text info (wrap-as `((#:label ,break-label))))))
         (clone info
                #:locals locals)))

      ((if ,test ,then ,else)
       (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
              (here (number->string (length text)))
              (label (string-append "_" (.function info) "_" here "_"))
              (break-label (string-append label "break"))
              (else-label (string-append label "else"))
              (info ((test-jump-label->info info else-label) test))
              (info (ast->info then info))
              (info (append-text info (wrap-as (as info 'jump break-label))))
              (info (append-text info (wrap-as `((#:label ,else-label)))))
              (info (ast->info else info))
              (info (append-text info (wrap-as `((#:label ,break-label))))))
         (clone info
                #:locals locals)))

      ;; Hmm?
      ((expr-stmt (cond-expr ,test ,then ,else))
       (let ((info (expr->register `(cond-expr ,test ,then ,else) info)))
         (free-register info)))

      ((switch ,expr (compd-stmt (block-item-list . ,statements)))
       (define (clause? o)
         (pmatch o
           ((case . _) 'case)
           ((default . _) 'default)
           ((labeled-stmt _ ,statement) (clause? statement))
           (_ #f)))
       (define clause-number
         (let ((i 0))
           (lambda (o)
             (let ((n i))
               (when (clause? (car o))
                 (set! i (1+ i)))
               n))))

       (define (flatten-cases c)
         (define (flatten-case o)
           (pmatch o
             ((case ,test (case . ,body))
              (cons `(case ,test (expr-stmt)) (flatten-case `(case ,@body))))
             ((case ,test ,case-body (case . ,body))
              (cons `(case ,test ,case-body) (flatten-case `(case ,@body))))
             ((default (case . ,body))
              (cons `(default (expr-stmt)) (flatten-case `(case ,@body))))
             ((default ,default-body (case . ,body))
              (cons `(default ,default-body) (flatten-case `(case ,@body))))
             ((case ,test (default . ,body))
              (cons `(case ,test (expr-stmt)) (flatten-case `(default ,@body))))
             ((default ,rest)
              (list o))
             ((case ,test)
              (list o))
             ((case ,test ,expr)
              (list o))
             (,s (list s))))
         (fold (lambda (x acc) (append acc (flatten-case x))) '() c))

       (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
              (statements (flatten-cases statements))
              (here (number->string (length text)))
              (label (string-append "_" (.function info) "_" here "_"))
              (break-label (string-append label "break"))
              (info (expr->register expr info))
              (info (clone info #:break (cons break-label (.break info))))
              (count (length (filter clause? statements)))
              (default? (find (cut eq? <> 'default) (map clause? statements)))
              (info (fold (cut switch->info #t label (1- count) <> <> <>) info statements
                          (unfold null? clause-number cdr statements)))
              (last-clause-label (string-append label "clause" (number->string count)))
              (default-label (string-append label "default"))
              (info (if (not default?) info
                        (append-text info (wrap-as (as info 'jump break-label)))))
              (info (append-text info (wrap-as `((#:label ,last-clause-label)))))
              (info (if (not default?) info
                        (append-text info (wrap-as (as info 'jump default-label)))))
              (info (append-text info (wrap-as `((#:label ,break-label))))))
         (clone info
                #:locals locals
                #:break (cdr (.break info)))))

      ((for ,init ,test ,step ,body)
       (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
              (here (number->string (length text)))
              (label (string-append "_" (.function info) "_" here "_"))
              (break-label (string-append label "break"))
              (loop-label (string-append label "loop"))
              (continue-label (string-append label "continue"))
              (initial-skip-label (string-append label "initial_skip"))
              (info (ast->info init info))
              (info (clone info #:break (cons break-label (.break info))))
              (info (clone info #:continue (cons continue-label (.continue info))))
              (info (append-text info (wrap-as (as info 'jump initial-skip-label))))
              (info (append-text info (wrap-as `((#:label ,loop-label)))))
              (info (ast->info body info))
              (info (append-text info (wrap-as `((#:label ,continue-label)))))
              (info (if (equal? step '(expr)) info
                        (let ((info (expr->register step info)))
                          (free-register info))))
              (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
              (info ((test-jump-label->info info break-label) test))
              (info (append-text info (wrap-as (as info 'jump loop-label))))
              (info (append-text info (wrap-as `((#:label ,break-label))))))
         (clone info
                #:locals locals
                #:break (cdr (.break info))
                #:continue (cdr (.continue info)))))

      ((while ,test ,body)
       (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
              (here (number->string (length text)))
              (label (string-append "_" (.function info) "_" here "_"))
              (break-label (string-append label "break"))
              (loop-label (string-append label "loop"))
              (continue-label (string-append label "continue"))
              (info (append-text info (wrap-as (as info 'jump continue-label))))
              (info (clone info #:break (cons break-label (.break info))))
              (info (clone info #:continue (cons continue-label (.continue info))))
              (info (append-text info (wrap-as `((#:label ,loop-label)))))
              (info (ast->info body info))
              (info (append-text info (wrap-as `((#:label ,continue-label)))))
              (info ((test-jump-label->info info break-label) test))
              (info (append-text info (wrap-as (as info 'jump loop-label))))
              (info (append-text info (wrap-as `((#:label ,break-label))))))
         (clone info
                #:locals locals
                #:break (cdr (.break info))
                #:continue (cdr (.continue info)))))

      ((do-while ,body ,test)
       (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
              (here (number->string (length text)))
              (label (string-append "_" (.function info) "_" here "_"))
              (break-label (string-append label "break"))
              (loop-label (string-append label "loop"))
              (continue-label (string-append label "continue"))
              (info (clone info #:break (cons break-label (.break info))))
              (info (clone info #:continue (cons continue-label (.continue info))))
              (info (append-text info (wrap-as `((#:label ,loop-label)))))
              (info (ast->info body info))
              (info (append-text info (wrap-as `((#:label ,continue-label)))))
              (info ((test-jump-label->info info break-label) test))
              (info (append-text info (wrap-as (as info 'jump loop-label))))
              (info (append-text info (wrap-as `((#:label ,break-label))))))
         (clone info
                #:locals locals
                #:break (cdr (.break info))
                #:continue (cdr (.continue info)))))

      ((labeled-stmt (ident ,label) ,statement)
       (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label)))))))
         (ast->info statement info)))

      ((goto (ident ,label))
       (append-text info (wrap-as (as info 'jump (string-append "_" (.function info) "_label_" label)))))

      ((return (expr))
       (let ((info (fold (lambda (x info) (free-register info)) info (.allocated info))))
         (append-text info (append (wrap-as (as info 'ret))))))

      ((return ,expr)
       (let* ((info (fold (lambda (x info) (free-register info)) info (.allocated info)))
              (info (expr->register expr info))
              (info (free-register info)))
         (append-text info (append (wrap-as (as info 'ret))))))

      ((decl . ,decl)
       (let ((info (append-text info (ast->comment o))))
         (decl->info info decl)))

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

      ((expr-stmt ,expression)
       (let* ((info (expr->register expression info))
              (info (append-text info (wrap-as (as info 'r-zero?)))))
         (fold (lambda (x info) (free-register info)) info (.allocated info))))

      (_ (let* ((info (expr->register o info))
                (info (append-text info (wrap-as (as info 'r-zero?)))))
           (fold (lambda (x info) (free-register info)) info (.allocated info)))))))

(define (ast-list->info o info)
  (fold ast->info info o))

(define (switch->info clause? label count o i info)
  (let* ((i-string (number->string i))
         (i+1-string (number->string (1+ i)))
         (body-label (string-append label "body" i-string))
         (clause-label (string-append label "clause" i-string))
         (first? (= i 0))
         (last? (= i count))
         (break-label (string-append label "break"))
         (next-clause-label (string-append label "clause" i+1-string))
         (default-label (string-append label "default")))
    (define (jump label)
      (wrap-as (as info 'jump label)))
    (pmatch o
      ((case ,test)
       (define (jump-nz label)
         (wrap-as (as info 'jump-nz label)))
       (define (jump-z label)
         (wrap-as (as info 'jump-z label)))
       (define (test->text test)
         (let ((value (pmatch test
                        (0 0)
                        ((p-expr (char ,value)) (char->integer (car (string->list value))))
                        ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
                        ((p-expr (fixed ,value)) (cstring->int value))
                        ((neg (p-expr (fixed ,value))) (- (cstring->int value)))
                        (_ (error "case test: not supported: " test)))))
           (append (wrap-as (as info 'r-cmp-value value))
                   (jump-z body-label))))
       (let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                       info)))
         (append-text info (test->text test))))
      ((case ,test (default . ,rest))
       (let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                       info)))
         (fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `(default ,@rest)))))
      ((case ,test ,statement)
       (let* ((info (if first? info (append-text info (jump body-label)))) ; Enables fallthrough
              (info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                        info))
              (info (switch->info #f label count `(case ,test) i info))
              (info (append-text info (jump next-clause-label)))
              (info (append-text info (wrap-as `((#:label ,body-label)))))
              (info (ast->info statement info)))
         info))
      ((default (case . ,case1) . ,rest)
       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                        info))
              (info (if last? info
                         (append-text info (jump next-clause-label))))
              (info (append-text info (wrap-as `((#:label ,default-label)))))
              (info (append-text info (jump body-label)))
              (info (append-text info (wrap-as `((#:label ,body-label))))))
         (fold (cut switch->info #f label count <> i <>) info `((case ,@case1) ,@rest))))
      (default
        (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                         info))
               (info (if last? info
                         (append-text info (jump next-clause-label))))
               (info (append-text info (wrap-as `((#:label ,default-label)))))
               (info (append-text info (jump body-label)))
               (info (append-text info (wrap-as `((#:label ,body-label))))))
          info))
      ((default ,statement)
       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                        info))
              (info (if last? info
                        (append-text info (jump next-clause-label))))
              (info (append-text info (wrap-as `((#:label ,default-label)))))
              (info (append-text info (wrap-as `((#:label ,body-label))))))
         (ast->info statement info)))
      ((default ,statement ,rest)
       (let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
                        info))
              (info (if last? info
                        (append-text info (jump next-clause-label))))
              (info (append-text info (wrap-as `((#:label ,default-label)))))
              (info (append-text info (wrap-as `((#:label ,body-label))))))
         (fold ast->info (ast->info statement info) rest)))
      ((labeled-stmt (ident ,goto-label) ,statement)
       (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" goto-label)))))))
         (switch->info clause? label count statement i info)))
      (_ (ast->info o info)))))

(define (global->static function)
  (lambda (o)
    (cons (car o) (set-field (cdr o) (global:function) function))))

(define (decl->info info o)
  (pmatch o
    (((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits))
     (let* ((info (type->info type #f info))
            (type (ast->type type info)))
       (fold (cut init-declr->info type 'storage <> <>) info (map cdr inits))))
    (((decl-spec-list (type-spec ,type)))
     (type->info type #f info))
    (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name))))
     (let* ((info (type->info type name info))
            (type (ast->type type info)))
       (clone info #:types (acons name type (.types info)))))
    ;; FIXME: recursive types, pointer, array
    (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
     (let* ((info (type->info type name info))
            (type (ast->type type info))
            (count (expr->number info count))
            (type (make-c-array type count)))
       (clone info #:types (acons name type (.types info)))))
    (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
     (let* ((info (type->info type name info))
            (type (ast->type type info))
            (rank (pointer->rank pointer))
            (type (rank+= type rank)))
       (clone info #:types (acons name type (.types info)))))
    (((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits))
     (let* ((info (type->info type #f info))
            (type (ast->type type info))
            (function (.function info)))
       (if (not function) (fold (cut init-declr->info type store <> <>) info (map cdr inits))
           (let* ((tmp (clone info #:function #f #:globals '()))
                  (tmp (fold (cut init-declr->info type store <> <>) tmp (map cdr inits)))
                  (statics (map (global->static function) (.globals tmp)))
                  (strings (filter string-global? (.globals tmp))))
             (clone info #:globals (append (.globals info) strings)
                    #:statics (append statics (.statics info)))))))
    (((decl-spec-list (stor-spec (,store)) (type-spec ,type)))
     (type->info type #f info))
    (((@ . _))
     (format (current-error-port) "decl->info: skip: ~s\n" o)
     info)
    (_ (error "decl->info: not supported:" o))))

(define (ast->name o)
  (pmatch o
    ((ident ,name) name)
    ((array-of ,array . ,_) (ast->name array))
    ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) . _) name)
    ((ptr-declr ,pointer ,decl . ,_) (ast->name decl))
    ((ptr-declr ,pointer (ident ,name)) name)
    (_ (error "ast->name not supported: " o))))

(define (init-declr->count info o)
  (pmatch o
    ((array-of (ident ,name) ,count) (expr->number info count))
    (_ #f)))

(define (init->r o info)
  (pmatch o
    ((initzer-list (initzer ,expr))
     (expr->register expr info))
    (((#:string ,string))
     (expr->register `(p-expr (string ,string)) info))
    ((,number . _) (guard (number? number))
     (expr->register `(p-expr (fixed 0)) info))
    ((,c . ,_) (guard (char? c))
     info)
    (_
     (expr->register o info))))

(define (init-struct-field local field n init info)
  (let* ((offset (field-offset info (local:type local) (car field)))
         (size (field:size field info))
         (offset (+ offset (* n size)))
         (info (expr->register init info))
         (info (allocate-register info))
         (info (append-text info (local->r local info)))
         (info (append-text info (wrap-as (as info 'r+value offset))))
         (reg-size (->size "*" info))
         (size (min size reg-size))
         (info (r0->r1-mem*n info size size))
         (info (free-register info))
         (info (free-register info)))
    info))

(define (init-struct-struct-field local type offset field init info)
  (let* ((offset (+ offset (field-offset info type (car field))))
         (size (field:size field info))
         (info (expr->register init info))
         (info (allocate-register info))
         (info (append-text info (local->r local info)))
         (info (append-text info (wrap-as (as info 'r+value offset))))
         (reg-size (->size "*" info))
         (size (min size reg-size))
         (info (r0->r1-mem*n info size size))
         (info (free-register info))
         (info (free-register info)))
    info))

(define (init-array-entry local index init info)
  (let* ((type (local:type local))
         (size (cond ((pointer? type) (->size "*" info))
                     ((and (c-array? type) ((compose pointer? c-array:type) type)) (->size "*" info))
                     ((c-array? type) ((compose type:size c-array:type) type))
                     (else (type:size type))))
         (offset (* index size))
         (info (expr->register init info))
         (info (allocate-register info))
         (info (append-text info (local->r local info)))
         (info (append-text info (wrap-as (as info 'r+value offset))))
         (reg-size (->size "*" info))
         (size (min size reg-size))
         (info (r0->r1-mem*n info size size))
         (info (fold (lambda (x info) (free-register info)) info (.allocated info))))
    info))

(define (init-local local o n info)
  (pmatch o
    (#f info)
    ((initzer ,init)
     (init-local local init n info))
    ((initzer-list . ,inits)
     (let ((local-type (local:type local)))
       (cond ((structured-type? local)
              (let* ((fields (struct->init-fields local-type))
                     (field+counts (let loop ((fields fields))
                                     (if (null? fields) '()
                                         (let* ((field (car fields))
                                                (type (cdr field)))
                                           (cond ((c-array? type)
                                                  (append (map
                                                           (lambda (i)
                                                             (let ((field (cons (car field) (c-array:type type))))
                                                               (cons field i)))
                                                           (iota (c-array:count type)))
                                                          (loop (cdr fields))))
                                                 (else
                                                  (cons (cons field 0) (loop (cdr fields))))))))))
                (let loop ((field+counts field+counts) (inits inits) (info info))
                  (if (null? field+counts) info
                      (let* ((field (caaar field+counts))
                             (type (cdaar field+counts)))
                        (if (and (type? type)
                                 (eq? (type:type type) 'struct))
                            (let* ((field-fields (type:description type))
                                   (field-inits (list-head inits (max (length inits) (length field-fields))))
                                   (missing (max 0 (- (length field-fields) (length field-inits))))
                                   (field-inits+ (append field-inits (map (const '(p-expr (fixed "0"))) (iota missing))))
                                   (offset (field-offset info local-type field))
                                   ;; (info (init-local local `(initzer-list ,field-inits) n info))
                                   ;; crap, howto recurse? -- would need new local for TYPE
                                   ;; just do two deep for now
                                   (info (fold (cut init-struct-struct-field local type offset <> <> <>) info field-fields field-inits+)))
                              (loop (list-tail field+counts (min (length field+counts) (length field-fields)))
                                    (list-tail inits (min (length field-inits) (length field-inits))) info))
                            (let* ((missing (max 0 (- (length field+counts) (length inits))))
                                   (counts (map cdr field+counts))
                                   (fields (map car field+counts))
                                   (info (fold (cut init-struct-field local <> <> <> <>) info fields counts (append inits (map (const '(p-expr (fixed "0"))) (iota missing))))))
                              ;; bah, loopme!
                              ;;(loop (list-tail field+counts (length field-fields)) (list-tail inits (length field-inits)) info)
                              info)))))))
             (else
              (let* ((type (local:type local))
                     (type (if (c-array? type) (c-array:type type) type))
                     (size (->size type info)))
                (fold (cut init-local local <> <> <>) info inits (iota (length inits) 0 size)))))))
    (,string (guard (string? string))
             (let ((inits (string->list string)))
               (fold (cut init-array-entry local <> <> <>) info (iota (length inits)) inits)))

    (((initzer (initzer-list . ,inits)))
     (init-local local (car o) n info))

    (() info)
    (_ (let* ((info (init->r o info))
              (info (append-text info (r->local+n-text info local n))))
         (free-register info)))))

(define (local->info type name o init info)
  (let* ((locals (.locals info))
         (id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
                 (1+ (local:id (cdar locals)))))
         (local (make-local-entry name type id))
         (pointer (->rank (cdr local)))
         (array? (or (and (c-array? type) type)
                     (and (pointer? type)
                          (c-array? (pointer:type type))
                          (pointer:type type))
                     (and (pointer? type)
                          (pointer? (pointer:type type))
                          (c-array? (pointer:type (pointer:type type)))
                          (pointer:type (pointer:type type)))))
         (struct? (structured-type? type))
         (size (->size type info))
         (string (and array? (array-init->string init)))
         (init (or string init))
         (reg-size (->size "*" info))
         (local (if (not array?) local
                    (let ((size (or (and string (max size (1+ (string-length string))))
                                    size)))
                      (make-local-entry name type (+ (local:id (cdr local)) -1 (quotient (+ size (1- reg-size)) reg-size))))))
         (local (if struct? (make-local-entry name type (+ (local:id (cdr local)) (quotient (+ size (1- reg-size)) reg-size)))
                    local))
         (locals (cons local locals))
         (info (clone info #:locals locals))
         (local (cdr local)))
    (init-local local init 0 info)))

(define (global->info storage type name o init info)
  (let* ((rank (->rank type))
         (size (->size type info))
         (data (cond ((not init) (string->list (make-string size #\nul)))
                     ((c-array? type)
                      (let* ((string (array-init->string init))
                             (size (or (and string (max size (1+ (string-length string))))
                                       size))
                             (data (or (and=> string string->list)
                                       (array-init->data type size init info))))
                        (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))
                     ((structured-type? type)
                      (let ((data (init->data type init info)))
                        (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))
                     (else
                      (let ((data (init->data type init info)))
                        (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))))
         (global (make-global-entry name storage type data)))
    (clone info #:globals (append (.globals info) (list global)))))

(define (array-init-element->data type o info)
  (pmatch o
    ((initzer (p-expr (string ,string)))
     (let ((reg-size (->size "*" info)))
       (if (= reg-size 8) `((#:string ,string) "%0")
           `((#:string ,string)))))
    ((initzer (p-expr (fixed ,fixed)))
     (if (structured-type? type)
         (let ((fields (map cdr (struct->init-fields type))))
           (int->bv type (expr->number info fixed) info))
         (int->bv type (expr->number info fixed) info)))
    ((initzer (initzer-list . ,inits))
     (cond ((structured-type? type)
            (let* ((fields (map cdr (struct->init-fields type)))
                   (missing (max 0 (- (length fields) (length inits))))
                   (inits (append inits
                                  (map (const '(fixed "0")) (iota missing)))))
              (map (cut array-init-element->data <> <> info) fields inits)))
           ((c-array? type)
            (let* ((missing (max 0 (- (c-array:count type) (length inits))))
                   (inits (append inits
                                  (map (const '(fixed "0")) (iota missing)))))
              (map (cut array-init-element->data (c-array:type type) <> info) inits)))
         (else
          (format (current-error-port) "array-init-element->data: oops:~s\n" o)
          (format (current-error-port) "type:~s\n" type)
          (error "array-init-element->data: not supported: " o))))
    (_ (init->data type o info))
    (_ (error "array-init-element->data: not supported: " o))))

(define (array-init->data type size o info)
  (pmatch o
    ((initzer (initzer-list . ,inits))
     (let ((type (c-array:type type)))
       (if (structured-type? type)
           (let* ((init-fields (struct->init-fields type)) ;; FIXME
                  (count (length init-fields)))
             (let loop ((inits inits))
               (if (null? inits) '()
                   (let ((init (car inits)))
                     (pmatch init
                       ((initzer (initzer-list . ,car-inits))
                        (append (array-init-element->data type init info)
                                (loop (cdr inits))))
                       (_
                        (let* ((count (min (length inits) (length init-fields)))
                                 (field-inits (list-head inits count)))
                          (append (array-init-element->data type `(initzer-list ,@field-inits) info)
                           (loop (list-tail inits count))))))))))
           (map (cut array-init-element->data type <> info) inits))))

    (((initzer (initzer-list . ,inits)))
     (array-init->data type size (car o) info))

    ((initzer (p-expr (string ,string)))
     (let ((data (string->list string)))
       (if (not size) data
           (append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))

    (((initzer (p-expr (string ,string))))
     (array-init->data type size (car o) info))

    ((initzer (p-expr (string . ,strings)))
     (let ((data (string->list (apply string-append strings))))
       (if (not size) data
           (append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))

    (((initzer (p-expr (string . ,strings))))
     (array-init->data type size (car o) info))

    ((initzer (p-expr (fixed ,fixed)))
     (int->bv type (expr->number info fixed) info))

    (() (string->list (make-string size #\nul)))
    (_ (error "array-init->data: not supported: " o))))

(define (array-init->string o)
  (pmatch o
    ((p-expr (string ,string)) string)
    ((p-expr (string . ,strings)) (apply string-append strings))
    ((initzer ,init) (array-init->string init))
    (((initzer ,init)) (array-init->string init))
    ((initzer-list (initzer (p-expr (char ,c))) . ,inits)
     (list->string (map (lambda (i) (pmatch i
                                      ((initzer (p-expr (char ,c))) ((compose car string->list) c))
                                      ((initzer (p-expr (fixed ,fixed)))
                                       (let ((value (cstring->int fixed)))
                                         (if (and (>= value 0) (<= value 255))
                                             (integer->char value)
                                             (error "array-init->string: not supported:" i o))))
                                      (_ (error "array-init->string: not supported:" i o))))
                        (cdr o))))
    (_ #f)))

(define (init-declr->info type storage o info)
  (pmatch o
    (((ident ,name))
     (if (.function info) (local->info type name o #f info)
         (global->info storage type name o #f info)))
    (((ident ,name) (initzer ,init))
     (let* ((strings (init->strings init info))
            (info (if (null? strings) info
                      (clone info #:globals (append (.globals info) strings)))))
       (if (.function info) (local->info type name o init info)
           (global->info storage type name o init info))))
    (((ftn-declr (ident ,name) . ,_))
     (let ((functions (.functions info)))
       (if (member name functions) info
           (let ((function (make-function name type #f)))
             (clone info #:functions (cons (cons name function) functions))))))
    (((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list) ,init)
     (let* ((rank (pointer->rank pointer))
            (type (rank+= type rank)))
       (if (.function info) (local->info type name o init info)
           (global->info storage type name o init info))))
    (((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list))
     (let* ((rank (pointer->rank pointer))
            (type (rank+= type rank)))
       (if (.function info) (local->info type name o '() info)
           (global->info storage type name o '() info))))
    (((ptr-declr ,pointer . ,_) . ,init)
     (let* ((rank (pointer->rank pointer))
            (type (rank+= type rank)))
       (init-declr->info type storage (append _ init) info)))
    (((array-of (ident ,name) ,count) . ,init)
     (let* ((strings (init->strings init info))
            (info (if (null? strings) info
                      (clone info #:globals (append (.globals info) strings))))
            (count (expr->number info count))
            (type (make-c-array type count)))
       (if (.function info) (local->info type name o init info)
           (global->info storage type name o init info))))
    (((array-of (ident ,name)) . ,init)
     (let* ((strings (init->strings init info))
            (info (if (null? strings) info
                      (clone info #:globals (append (.globals info) strings))))
            (count (length (cadar init)))
            (type (make-c-array type count)))
       (if (.function info) (local->info type name o init info)
           (global->info storage type name o init info))))
    ;; FIXME: recursion
    (((array-of (array-of (ident ,name) ,count1) ,count) . ,init)
     (let* ((strings (init->strings init info))
            (info (if (null? strings) info
                      (clone info #:globals (append (.globals info) strings))))
            (count (expr->number info count))
            (count1 (expr->number info count1))
            (type (make-c-array (make-c-array type count1) count)))
       (if (.function info) (local->info type name o init info)
           (global->info storage type name o init info))))
    (_ (error "init-declr->info: not supported: " o))))

(define (enum-def-list->constants constants fields)
  (let loop ((fields fields) (i 0) (constants constants))
    (if (pair? fields)
        (let ((field (car fields)))
          (mescc:trace (cadr (cadr field)) " <e>")))
    (if (null? fields) constants
        (let* ((field (car fields))
               (name (pmatch field
                       ((enum-defn (ident ,name) . _) name)))
               (i (pmatch field
                    ((enum-defn ,name) i)
                    ((enum-defn ,name ,exp) (expr->number #f exp))
                    (_ (error "not supported enum field=~s\n" field)))))
          (loop (cdr fields)
                (1+ i)
                (append constants (list (ident->constant name i))))))))

(define (init->data type o info)
  (pmatch o
    ((p-expr ,expr) (init->data type expr info))
    ((fixed ,fixed) (int->bv type (expr->number info o) info))
    ((char ,char) (int->bv type (char->integer (string-ref char 0)) info))
    ((string ,string)
     (let ((reg-size (->size "*" info)))
       (if (= reg-size 8) `((#:string ,string) "%0")
           `((#:string ,string)))))
    ((string . ,strings)
     (let ((reg-size (->size "*" info)))
       (if (= reg-size 8) `((#:string ,(string-join strings "")) "%0")
           `((#:string ,(string-join strings ""))))))
    ((ident ,name) (let ((var (ident->variable info name)))
                     (if (number? var) (int->bv type var info)
                         `((#:address ,var)))))
    ((initzer-list . ,inits)
     (cond ((structured-type? type)
            (map (cut init->data <> <> info) (map cdr (struct->init-fields type)) inits))
           ((c-array? type)
            (let ((size (->size type info)))
              (array-init->data type size `(initzer ,o) info)))
           (else
            (append-map (cut init->data type <> info) inits))))
    (((initzer (initzer-list . ,inits)))
     (init->data type `(initzer-list . ,inits) info))
    ((ref-to (p-expr (ident ,name)))
     (let ((var (ident->variable info name))
           (reg-size (->size "*" info)))
       `((#:address ,var)
         ,@(if (= reg-size 8) '((#:address 0))
               '()))))
    ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
     (let* ((type (ast->type struct info))
            (offset (field-offset info type field))
            (base (cstring->int base)))
       (int->bv type (+ base offset) info)))
    ((,char . _) (guard (char? char)) o)
    ((,number . _) (guard (number? number))
     (append (map (cut int->bv <> <> info) type o)))
    ((initzer ,init) (init->data type init info))
    (((initzer ,init)) (init->data type init info))
    ((cast _ ,expr) (init->data type expr info))
    (() '())
    (_ (let ((number (try-expr->number info o)))
         (cond (number (int->bv type number info))
               (else (error "init->data: not supported: " o)))))))

(define (int->bv type o info)
  (let ((size (->size type info)))
    (case size
      ((1) (int->bv8 o))
      ((2) (int->bv16 o))
      ((4) (int->bv32 o))
      ((8) (int->bv64 o))
      (else (int->bv64 o)))))

(define (init->strings o info)
  (let ((globals (.globals info)))
    (pmatch o
      ((p-expr (string ,string))
       (let ((g `(#:string ,string)))
         (if (assoc g globals) '()
             (list (string->global-entry string)))))
      ((p-expr (string . ,strings))
       (let* ((string (string-join strings ""))
              (g `(#:string ,string)))
         (if (assoc g globals) '()
             (list (string->global-entry string)))))
      (((initzer (initzer-list . ,init)))
       (append-map (cut init->strings <> info) init))
      ((initzer ,init)
       (init->strings init info))
      (((initzer ,init))
       (init->strings init info))
      ((initzer-list . ,init)
       (append-map (cut init->strings <> info) init))
      (_ '()))))

(define (type->info o name info)
  (pmatch o

    ((enum-def (ident ,name) (enum-def-list . ,fields))
     (mescc:trace name " <t>")
     (let* ((type-entry (enum->type-entry name fields))
            (constants (enum-def-list->constants (.constants info) fields)))
       (clone info
              #:types (cons type-entry (.types info))
              #:constants (append constants (.constants info)))))

    ((enum-def (enum-def-list . ,fields))
     (mescc:trace name " <t>")
     (let* ((type-entry (enum->type-entry name fields))
            (constants (enum-def-list->constants (.constants info) fields)))
       (clone info
              #:types (cons type-entry (.types info))
              #:constants (append constants (.constants info)))))

    ((struct-def (field-list . ,fields))
     (mescc:trace name " <t>")
     (let* ((info (fold field->info info fields))
            (type-entry (struct->type-entry info name (append-map (struct-field info) fields))))
       (clone info #:types (cons type-entry (.types info)))))

    ((struct-def (ident ,name) (field-list . ,fields))
     (mescc:trace name " <t>")
     (let* ((info (fold field->info info fields))
            (type-entry (struct->type-entry info name (append-map (struct-field info) fields))))
       (clone info #:types (cons type-entry (.types info)))))

    ((union-def (ident ,name) (field-list . ,fields))
     (mescc:trace name " <t>")
     (let ((type-entry (union->type-entry info name (append-map (struct-field info) fields))))
       (clone info #:types (cons type-entry (.types info)))))

    ((union-def (field-list . ,fields))
     (mescc:trace name " <t>")
     (let ((type-entry (union->type-entry info name (append-map (struct-field info) fields))))
       (clone info #:types (cons type-entry (.types info)))))

    ((enum-ref . _) info)
    ((struct-ref . _) info)
    ((typename ,name) info)
    ((union-ref . _) info)
    ((fixed-type . _) info)
    ((float-type . _) info)
    ((void) info)

    (_ ;;(error "type->info: not supported:" o)
     info
     )))

(define (field->info o info)
  (pmatch o
    ((comp-decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))) . _)
     (let* ((fields (append-map (struct-field info) fields))
            (struct (make-type 'struct (apply + (map (cut field:size <> info) fields)) fields)))
       (clone info #:types (acons `(tag ,name) struct (.types info)))))
    ((comp-decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))) . _)
     (let* ((fields (append-map (struct-field info) fields))
            (union (make-type 'union (apply + (map (cut field:size <> info) fields)) fields)))
       (clone info #:types (acons `(tag ,name) union (.types info))) ))
    ((comp-decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))) . _)
     (let ((constants (enum-def-list->constants (.constants info) fields)))
       (clone info
              #:constants (append constants (.constants info)))))
    ((comp-decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))) . _)
     (let ((constants (enum-def-list->constants (.constants info) fields))
           (type-entry (enum->type-entry name fields)))
       (clone info
              #:types (cons type-entry (.types info))
              #:constants (append constants (.constants info)))))
    (_ info)))

;;; fctn-defn
(define (param-decl:get-name o)
  (pmatch o
    ((ellipsis) #f)
    ((param-decl (decl-spec-list (type-spec (void)))) #f)
    ((param-decl _ (param-declr ,ast)) (ast->name ast))
    (_ (error "param-decl:get-name not supported:" o))))

(define (fctn-defn:get-name o)
  (pmatch o
    ((_ (ftn-declr (ident ,name) _) _) name)
    ((_ (ftn-declr (scope (ident ,name)) _) _) name)
    ((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name)
    (_ (error "fctn-defn:get-name not supported:" o))))

(define (param-decl:get-type o info)
  (pmatch o
    ((ellipsis) #f)
    ((param-decl (decl-spec-list ,type)) (ast->type type info))
    ((param-decl (decl-spec-list (type-spec ,type)) (param-declr (ptr-declr ,pointer (ident ,name))))
     (let ((rank (pointer->rank pointer)))
       (rank+= (ast->type type info) rank)))
    ((param-decl (decl-spec-list ,type) (param-declr (ptr-declr ,pointer (array-of _))))
     (let ((rank (pointer->rank pointer)))
       (rank+= (ast->type type info) (1+ rank))))
    ((param-decl ,type _) (ast->type type info))
    (_ (error "param-decl:get-type not supported:" o))))

(define (fctn-defn:get-formals o)
  (pmatch o
    ((_ (ftn-declr _ ,formals) _) formals)
    ((_ (ptr-declr (pointer . _) (ftn-declr _ ,formals)) _) formals)
    (_ (error "fctn-defn->formals: not supported:" o))))

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

(define (param-list->text o info)
  (pmatch o
    ((param-list . ,formals)
     (let ((n (length formals)))
       (wrap-as (append (as info 'function-preamble formals)
                        (append-map (formal->text n) formals (iota n))
                        (as info 'function-locals)))))
    (_ (error "param-list->text: not supported: " o))))

(define (param-list->locals o info)
  (pmatch o
    ((param-list . ,formals)
     (let ((n (length formals)))
       (map make-local-entry
            (map param-decl:get-name formals)
            (map (cut param-decl:get-type <> info) formals)
            (iota n -2 -1))))
    (_ (error "param-list->locals: not supported:" o))))

(define (fctn-defn:get-type info o)
  (pmatch o
    (((decl-spec-list (type-spec ,type)) (ptr-declr ,pointer . _) ,statement)
     (let* ((type (ast->type type info))
            (rank (ptr-declr->rank pointer)))
       (if (zero? rank) type
           (make-pointer type rank))))
    (((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ptr-declr ,pointer . _) ,statement)
     (let* ((type (ast->type type info))
            (rank (ptr-declr->rank pointer)))
       (if (zero? rank) type
           (make-pointer type rank))))
    (((decl-spec-list (type-spec ,type)) . _)
     (ast->type type info))
    (((decl-spec-list (stor-spec ,store) (type-spec ,type)) . _)
     (ast->type type info))
    (_ (error "fctn-defn:get-type: not supported:" o))))

(define (fctn-defn:get-statement o)
  (pmatch o
    ((_ (ftn-declr (ident _) _) ,statement) statement)
    ((_ (ftn-declr (scope (ident _)) _) ,statement) statement)
    ((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement)
    (_ (error "fctn-defn:get-statement: not supported: " o))))

(define (fctn-defn->info o info)
  (define (assert-return text)
    (let ((return (wrap-as (as info 'ret))))
      (if (equal? (list-tail text (- (length text) (length return))) return) text
          (append text return))))
  (let ((name (fctn-defn:get-name o)))
    (mescc:trace name)
    (let* ((type (fctn-defn:get-type info o))
           (formals (fctn-defn:get-formals o))
           (text (param-list->text formals info))
           (locals (param-list->locals formals info))
           (statement (fctn-defn:get-statement o))
           (function (cons name (make-function name type '())))
           (functions (cons function (.functions info)))
           (info (clone info #:locals locals #:function name #:text text #:functions functions #:statics '()))
           (info (ast->info statement info))
           (locals (.locals info))
           (local (and (pair? locals) (car locals)))
           (count (and=> local (compose local:id cdr)))
           (reg-size (->size "*" info))
           (stack (and count (* count reg-size))))
      (if (and stack (getenv "MESC_DEBUG")) (format (current-error-port) "        stack: ~a\n" stack))
      (clone info
             #:function #f
             #:globals (append (.statics info) (.globals info))
             #:statics '()
             #:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info))))))))))