module/language/c99/compiler.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; compiler.mes produces an i386 binary from the C produced by
  24 ;;; Nyacc c99.
  25
  26 ;;; Code:
  27
  28 (cond-expand
  29  (guile-2
  30   (set-port-encoding! (current-output-port) "ISO-8859-1"))
  31  (guile)
  32  (mes
  33   (mes-use-module (mes pmatch))
  34   (mes-use-module (nyacc lang c99 parser))
  35   (mes-use-module (mes elf-util))
  36   (mes-use-module (mes elf))
  37   (mes-use-module (mes as-i386))
  38   (mes-use-module (mes optargs))))
  39
  40 (define (logf port string . rest)
  41   (apply format (cons* port string rest))
  42   (force-output port)
  43   #t)
  44
  45 (define (stderr string . rest)
  46   (apply logf (cons* (current-error-port) string rest)))
  47
  48 (define %datadir (if (string-prefix? "@DATADIR" "@DATADIR@") "" "@DATADIR@"))
  49 (define %docdir (if (string-prefix? "@DOCDIR" "@DOCDIR@") "doc/" "@DOCDIR@"))
  50 (define %moduledir "module/")
  51 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
  52 (define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
  53
  54 (define mes? (pair? (current-module)))
  55
  56 (define* (c99-input->ast #:key (defines '()) (includes '()))
  57   (parse-c99
  58    #:inc-dirs (append includes (cons* "." "libc/include" "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:)))
  59    #:cpp-defs `(
  60                 "POSIX=0"
  61                 "_POSIX_SOURCE=0"
  62                 "__GNUC__=0"
  63                 "__MESC__=1"
  64                 "__NYACC__=1" ;; REMOVEME
  65                 "EOF=-1"
  66                 "STDIN=0"
  67                 "STDOUT=1"
  68                 "STDERR=2"
  69
  70                 "INT_MIN=-2147483648"
  71                 "INT_MAX=2147483647"
  72
  73                 "MES_FULL=0"
  74                 "FIXED_PRIMITIVES=1"
  75
  76                 ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
  77
  78                 ,(string-append "DATADIR=\"" %datadir "\"")
  79                 ,(string-append "DOCDIR=\"" %docdir "\"")
  80                 ,(string-append "PREFIX=\"" %prefix "\"")
  81                 ,(string-append "MODULEDIR=\"" %moduledir "\"")
  82                 ,(string-append "VERSION=\"" %version "\"")
  83                 ,@defines
  84                 )
  85    #:mode 'code))
  86
  87 (define (ast:function? o)
  88   (and (pair? o) (eq? (car o) 'fctn-defn)))
  89
  90 (define (.name o)
  91   (pmatch o
  92     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
  93     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
  94     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) _) name)
  95     ((param-decl _ (param-declr (ident ,name))) name)
  96     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
  97     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
  98     ((param-decl _ (param-declr (ptr-declr (pointer (pointer)) (ident ,name)))) name)
  99     (_
 100      (format (current-error-port) "SKIP: .name =~a\n" o))))
 101
 102 (define (.type o)
 103   (pmatch o
 104     ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
 105     ((param-decl ,type _) type)
 106     (_
 107      (format (current-error-port) "SKIP: .type =~a\n" o))))
 108
 109 (define (.statements o)
 110   (pmatch o
 111     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
 112     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
 113     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
 114     (_ (error ".statements: unsupported: " o))))
 115
 116 (define <info> '<info>)
 117 (define <types> '<types>)
 118 (define <constants> '<constants>)
 119 (define <functions> '<functions>)
 120 (define <globals> '<globals>)
 121 (define <init> '<init>)
 122 (define <locals> '<locals>)
 123 (define <function> '<function>)
 124 (define <text> '<text>)
 125 (define <break> '<break>)
 126
 127 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()) (break '()))
 128   (pmatch o
 129     (<info> (list <info>
 130                   (cons <types> types)
 131                   (cons <constants> constants)
 132                   (cons <functions> functions)
 133                   (cons <globals> globals)
 134                   (cons <init> init)
 135                   (cons <locals> locals)
 136                   (cons <function> function)
 137                   (cons <text> text)
 138                   (cons <break> break)))))
 139
 140 (define (.types o)
 141   (pmatch o
 142     ((<info> . ,alist) (assq-ref alist <types>))))
 143
 144 (define (.constants o)
 145   (pmatch o
 146     ((<info> . ,alist) (assq-ref alist <constants>))))
 147
 148 (define (.functions o)
 149   (pmatch o
 150     ((<info> . ,alist) (assq-ref alist <functions>))))
 151
 152 (define (.globals o)
 153   (pmatch o
 154     ((<info> . ,alist) (assq-ref alist <globals>))))
 155
 156 (define (.init o)
 157   (pmatch o
 158     ((<info> . ,alist) (assq-ref alist <init>))))
 159
 160 (define (.locals o)
 161   (pmatch o
 162     ((<info> . ,alist) (assq-ref alist <locals>))))
 163
 164 (define (.function o)
 165   (pmatch o
 166     ((<info> . ,alist) (assq-ref alist <function>))))
 167
 168 (define (.text o)
 169   (pmatch o
 170     ((<info> . ,alist) (assq-ref alist <text>))))
 171
 172 (define (.break o)
 173   (pmatch o
 174     ((<info> . ,alist) (assq-ref alist <break>))))
 175
 176 (define (info? o)
 177   (and (pair? o) (eq? (car o) <info>)))
 178
 179 (define (clone o . rest)
 180   (cond ((info? o)
 181          (let ((types (.types o))
 182                (constants (.constants o))
 183                (functions (.functions o))
 184                (globals (.globals o))
 185                (init (.init o))
 186                (locals (.locals o))
 187                (function (.function o))
 188                (text (.text o))
 189                (break (.break o)))
 190            (let-keywords rest
 191                          #f
 192                          ((types types)
 193                           (constants constants)
 194                           (functions functions)
 195                           (globals globals)
 196                           (init init)
 197                           (locals locals)
 198                           (function function)
 199                           (text text)
 200                           (break break))
 201                          (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text #:break break))))))
 202
 203 (define (push-global globals)
 204   (lambda (o)
 205     (list
 206      `(lambda (f g ta t d)
 207         (i386:push-global (+ (data-offset ,o g) d))))))
 208
 209 (define (push-local locals)
 210   (lambda (o)
 211     (wrap-as (i386:push-local (local:id o)))))
 212
 213 (define (push-global-address globals)
 214   (lambda (o)
 215     (list
 216      `(lambda (f g ta t d)
 217        (i386:push-global-address (+ (data-offset ,o g) d))))))
 218
 219 (define (push-local-address locals)
 220   (lambda (o)
 221     (wrap-as (i386:push-local-address (local:id o)))))
 222
 223 (define push-global-de-ref push-global)
 224
 225 (define (push-local-de-ref info)
 226   (lambda (o)
 227     (let* ((local o)
 228            (ptr (local:pointer local))
 229            (size (if (= ptr 1) (type->size info (local:type o))
 230                      4)))
 231       (if (= size 1)
 232           (wrap-as (i386:push-byte-local-de-ref (local:id o)))
 233           (wrap-as (i386:push-local-de-ref (local:id o)))))))
 234
 235
 236 (define (push-local-de-de-ref info)
 237   (lambda (o)
 238     (let* ((local o)
 239            (ptr (local:pointer local))
 240            (size (if (= ptr 2) (type->size info (local:type o));; URG
 241                      4)))
 242       (if (= size 1)
 243           (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
 244           (error "TODO int-de-de-ref")))))
 245
 246 (define (string->global string)
 247   (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
 248
 249 (define (int->global value)
 250   (make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value)))
 251
 252 (define (ident->global name type pointer value)
 253   (make-global name type pointer (int->bv32 value)))
 254
 255 (define (make-local name type pointer id)
 256   (cons name (list type pointer id)))
 257 (define local:type car)
 258 (define local:pointer cadr)
 259 (define local:id caddr)
 260
 261 (define (push-ident info)
 262   (lambda (o)
 263     (let ((local (assoc-ref (.locals info) o)))
 264       (if local
 265           (begin
 266             (let* ((ptr (local:pointer local))
 267                    (size (if (= ptr 1) (type->size info (local:type local))
 268                              4)))
 269              (if (= ptr -1) ((push-local-address (.locals info)) local)
 270                  ((push-local (.locals info)) local))))
 271           (let ((global (assoc-ref (.globals info) o)))
 272             (if global
 273                 ((push-global (.globals info)) o) ;; FIXME: char*/int
 274                 (let ((constant (assoc-ref (.constants info) o)))
 275                   (if constant
 276                       (wrap-as (append (i386:value->accu constant)
 277                                        (i386:push-accu)))
 278                       (error "TODO:push-function: " o)))))))))
 279
 280 (define (push-ident-address info)
 281   (lambda (o)
 282     (let ((local (assoc-ref (.locals info) o)))
 283       (if local ((push-local-address (.locals info)) local)
 284           ((push-global-address (.globals info)) o)))))
 285
 286 (define (push-ident-de-ref info)
 287   (lambda (o)
 288     (let ((local (assoc-ref (.locals info) o)))
 289       (if local ((push-local-de-ref info) local)
 290           ((push-global-de-ref (.globals info)) o)))))
 291
 292 (define (push-ident-de-de-ref info)
 293   (lambda (o)
 294     (let ((local (assoc-ref (.locals info) o)))
 295       (if local ((push-local-de-de-ref info) local)
 296           (error "TODO: global push-local-de-de-ref")))))
 297
 298 (define (expr->arg info)
 299   (lambda (o)
 300     (let ((info ((expr->accu info) o)))
 301       (append-text info (wrap-as (i386:push-accu))))))
 302
 303 (define (globals:add-string globals)
 304   (lambda (o)
 305     (let ((string (add-s:-prefix o)))
 306       (if (assoc-ref globals string) globals
 307           (append globals (list (string->global o)))))))
 308
 309 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
 310   (lambda (o)
 311     (let ((text (.text info)))
 312       (pmatch o
 313
 314         ((p-expr (string ,string))
 315          (let* ((globals ((globals:add-string (.globals info)) string))
 316                 (info (clone info #:globals globals)))
 317            (append-text info ((push-global-address info) (add-s:-prefix string)))))
 318
 319         ((p-expr (ident ,name))
 320          (append-text info ((push-ident info) name)))
 321
 322         ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
 323                           (abs-declr (pointer)))
 324                ,cast)
 325          ((expr->arg info) cast))
 326
 327         ((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast)
 328          ((expr->arg info) cast))
 329
 330         ((de-ref (p-expr (ident ,name)))
 331          (append-text info ((push-ident-de-ref info) name)))
 332
 333         ((de-ref (de-ref (p-expr (ident ,name))))
 334          (append-text info ((push-ident-de-de-ref info) name)))
 335
 336         ((ref-to (p-expr (ident ,name)))
 337          (append-text info ((push-ident-address info) name)))
 338
 339         (_ (append-text ((expr->accu info) o)
 340                         (wrap-as (i386:push-accu))))))))
 341
 342 ;; FIXME: see ident->base
 343 (define (ident->accu info)
 344   (lambda (o)
 345     (let ((local (assoc-ref (.locals info) o))
 346           (global (assoc-ref (.globals info) o))
 347           (constant (assoc-ref (.constants info) o)))
 348       (if local
 349           (let* ((ptr (local:pointer local))
 350                  (type (ident->type info o))
 351                  (size (if (= ptr 0) (type->size info type)
 352                            4)))
 353             (case ptr
 354               ((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
 355               ((1) (wrap-as (i386:local->accu (local:id local))))
 356               (else
 357                (wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
 358                             (i386:local->accu (local:id local)))))))
 359           (if global
 360               (let* ((ptr (ident->pointer info o))
 361                      (type (ident->type info o))
 362                      (size (if (= ptr 1) (type->size info type)
 363                                4)))
 364                 (case ptr
 365                   ((-1) (list `(lambda (f g ta t d)
 366                                  (i386:global->accu (+ (data-offset ,o g) d)))))
 367                   ((1) (list `(lambda (f g ta t d)
 368                                 (i386:global-address->accu (+ (data-offset ,o g) d)))))
 369
 370                   ((2) (list `(lambda (f g ta t d)
 371                                 (append (i386:value->accu (+ (data-offset ,o g) d))))))
 372                   (else (list `(lambda (f g ta t d)
 373                                  (i386:global-address->accu (+ (data-offset ,o g) d)))))))
 374               (if constant (wrap-as (i386:value->accu constant))
 375                   (list `(lambda (f g ta t d)
 376                            (i386:global->accu (+ ta (function-offset ,o f)))))))))))
 377
 378 (define (ident-address->accu info)
 379   (lambda (o)
 380     (let ((local (assoc-ref (.locals info) o))
 381           (global (assoc-ref (.globals info) o))
 382           (constant (assoc-ref (.constants info) o)))
 383       (if local
 384           (let* ((ptr (local:pointer local))
 385                  (type (ident->type info o))
 386                  (size (if (= ptr 1) (type->size info type)
 387                            4)))
 388             ;;(stderr "ident->accu ~a => ~a\n" o ptr)
 389             (wrap-as (i386:local-ptr->accu (local:id local))))
 390           (if global
 391               (let ((ptr (ident->pointer info o)))
 392                 (case ptr
 393                   ;; ((1)
 394                   ;;  (list `(lambda (f g ta t d)
 395                   ;;          (i386:global->accu (+ (data-offset ,o g) d)))))
 396                   (else (list `(lambda (f g ta t d)
 397                                 (append (i386:value->accu (+ (data-offset ,o g) d))))))))
 398               (list `(lambda (f g ta t d)
 399                           (i386:global->accu (+ ta (function-offset ,o f))))))))))
 400
 401 (define (ident-address->base info)
 402   (lambda (o)
 403     (let ((local (assoc-ref (.locals info) o))
 404           (global (assoc-ref (.globals info) o))
 405           (constant (assoc-ref (.constants info) o)))
 406       (if local
 407           (let* ((ptr (local:pointer local))
 408                  (type (ident->type info o))
 409                  (size (if (= ptr 1) (type->size info type)
 410                            4)))
 411             (wrap-as (i386:local-ptr->base (local:id local))))
 412           (if global
 413               (let ((ptr (ident->pointer info o)))
 414                 (case ptr
 415                   ((1)
 416                    (list `(lambda (f g ta t d)
 417                            (i386:global->base (+ (data-offset ,o g) d)))))
 418                   (else (list `(lambda (f g ta t d)
 419                                 (append (i386:value->base (+ (data-offset ,o g) d))))))))
 420               (error "TODO ident-address->base" o))))))
 421
 422 (define (value->accu v)
 423   (wrap-as (i386:value->accu v)))
 424
 425 (define (accu->ident info)
 426   (lambda (o)
 427     (let ((local (assoc-ref (.locals info) o)))
 428       (if local
 429           (let ((ptr (local:pointer local)))
 430             (case ptr
 431               (else (wrap-as (i386:accu->local (local:id local))))))
 432           (let ((ptr (ident->pointer info o)))
 433             (list `(lambda (f g ta t d)
 434                     (i386:accu->global (+ (data-offset ,o g) d)))))))))
 435
 436 (define (base->ident info)
 437   (lambda (o)
 438     (let ((local (assoc-ref (.locals info) o)))
 439       (if local (wrap-as (i386:base->local (local:id local)))
 440           (list `(lambda (f g ta t d)
 441                   (i386:base->global (+ (data-offset ,o g) d))))))))
 442
 443 (define (base->ident-address info)
 444   (lambda (o)
 445     (let ((local (assoc-ref (.locals info) o)))
 446       (if local
 447           (let* ((ptr (local:pointer local))
 448                  (type (ident->type info o))
 449                  (size (if (= ptr 1) (type->size info type)
 450                            4)))
 451             (wrap-as (append (i386:local->accu (local:id local))
 452                              (if (= size 1) (i386:byte-base->accu-address)
 453                                  (i386:byte-base->accu-address)))))
 454           (error "TODO:base->ident-address-global" o)))))
 455
 456 (define (value->ident info)
 457   (lambda (o value)
 458     (let ((local (assoc-ref (.locals info) o)))
 459       (if local (wrap-as (i386:value->local (local:id local) value))
 460           (list `(lambda (f g ta t d)
 461                   (i386:value->global (+ (data-offset ,o g) d) value)))))))
 462
 463 (define (ident-add info)
 464   (lambda (o n)
 465     (let ((local (assoc-ref (.locals info) o)))
 466       (if local (wrap-as (i386:local-add (local:id local) n))
 467           (list `(lambda (f g ta t d)
 468                   (i386:global-add (+ (data-offset ,o g) d) ,n)))))))
 469
 470 (define (ident-address-add info)
 471   (lambda (o n)
 472     (let ((local (assoc-ref (.locals info) o)))
 473       (if local (wrap-as (append (i386:push-accu)
 474                                  (i386:local->accu (local:id local))
 475                                  (i386:accu-mem-add n)
 476                                  (i386:pop-accu)))
 477           (list `(lambda (f g ta t d)
 478                   (append (i386:push-accu)
 479                           (i386:global->accu (+ (data-offset ,o g) d))
 480                           (i386:accu-mem-add ,n)
 481                           (i386:pop-accu))))))))
 482
 483 ;; FIXME: see ident->accu
 484 (define (ident->base info)
 485   (lambda (o)
 486     (let ((local (assoc-ref (.locals info) o)))
 487       (if local
 488           (let* ((ptr (local:pointer local))
 489                  (type (ident->type info o))
 490                  (size (if (and type (= ptr 1)) (type->size info type)
 491                            4)))
 492             (case ptr
 493               ((-1) (wrap-as (i386:local-ptr->base (local:id local))))
 494               ((1) (wrap-as (i386:local->base (local:id local))))
 495               (else
 496                (wrap-as (if (= size 1) (i386:byte-local->base (local:id local))
 497                             (i386:local->base (local:id local)))))))
 498           (let ((global (assoc-ref (.globals info) o) ))
 499             (if global
 500                 (let ((ptr (ident->pointer info o)))
 501                   (case ptr
 502                     ((-1) (list `(lambda (f g ta t d)
 503                                   (i386:global->base (+ (data-offset ,o g) d)))))
 504                     ((2) (list `(lambda (f g ta t d)
 505                                  (i386:global->base (+ (data-offset ,o g) d)))))
 506                     (else (list `(lambda (f g ta t d)
 507                                   (i386:global-address->base (+ (data-offset ,o g) d)))))))
 508                 (let ((constant (assoc-ref (.constants info) o)))
 509                   (if constant (wrap-as (i386:value->base constant))
 510                       (list `(lambda (f g ta t d)
 511                               (i386:global->base (+ ta (function-offset ,o f)))))))))))))
 512
 513 (define (expr->accu info)
 514   (lambda (o)
 515     (let ((locals (.locals info))
 516           (constants (.constants info))
 517           (text (.text info))
 518           (globals (.globals info)))
 519       (define (add-local locals name type pointer)
 520         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
 521                        (1+ (local:id (cdar locals)))))
 522                (locals (cons (make-local name type pointer id) locals)))
 523           locals))
 524       (pmatch o
 525         ((expr) info)
 526         ((p-expr (string ,string))
 527          (let* ((globals (append globals (list (string->global string))))
 528                 (info (clone info #:globals globals)))
 529            (append-text info (list `(lambda (f g ta t d)
 530                                      (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))))
 531
 532         ((p-expr (string . ,strings))
 533          (append-text info (list `(lambda (f g ta t d)
 534                                    (i386:global->accu (+ (data-offset ,(add-s:-prefix (apply string-append strings)) g) d))))))
 535         ((p-expr (fixed ,value))
 536          (append-text info (value->accu (cstring->number value))))
 537
 538         ((p-expr (ident ,name))
 539          (append-text info ((ident->accu info) name)))
 540
 541         ((initzer ,initzer) ((expr->accu info) initzer))
 542
 543         ;; &foo
 544         ((ref-to (p-expr (ident ,name)))
 545          (append-text info ((ident-address->accu info) name)))
 546
 547         ;; &f.field
 548         ((ref-to (d-sel (ident ,field) (p-expr (ident ,array))))
 549          (let* ((type (ident->type info array))
 550                 (fields (type->description info type))
 551                 (field-size 4) ;; FIXME:4, not fixed
 552                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 553                 (text (.text info)))
 554            (append-text info (append ((ident->accu info) array)
 555                                      (wrap-as (i386:accu+n offset))))))
 556
 557         ;; &a[x];
 558         ((ref-to (array-ref ,index (p-expr (ident ,array))))
 559          ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
 560
 561         ((sizeof-expr (p-expr (ident ,name)))
 562          (let* ((type (ident->type info name))
 563                 (fields (or (type->description info type) '()))
 564                 (size (type->size info type)))
 565            (append-text info (wrap-as (i386:value->accu size)))))
 566
 567         ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name)))))
 568          (let* ((type name)
 569                 (fields (or (type->description info type) '()))
 570                 (size (type->size info type)))
 571            (append-text info (wrap-as (i386:value->accu size)))))
 572
 573         ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
 574          (let* ((type (list "struct" name))
 575                 (fields (or (type->description info type) '()))
 576                 (size (type->size info type)))
 577            (append-text info (wrap-as (i386:value->accu size)))))
 578
 579         ;; c+p expr->arg
 580         ;; g_cells[<expr>]
 581         ((array-ref ,index (p-expr (ident ,array)))
 582          (let* ((type (ident->type info array))
 583                 (ptr (ident->pointer info array))
 584                 (size (if (< ptr 2) (type->size info type)
 585                           4))
 586                 (info ((expr->accu* info) o)))
 587            (append-text info (wrap-as (append (case size
 588                                                 ((1) (i386:byte-mem->accu))
 589                                                 ((4) (i386:mem->accu))
 590                                                 (else '())))))))
 591
 592         ;; f.field
 593         ((d-sel (ident ,field) (p-expr (ident ,array)))
 594          (let* ((type (ident->type info array))
 595                 (fields (type->description info type))
 596                 (field-size 4) ;; FIXME:4, not fixed
 597                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 598                 (text (.text info)))
 599            (append-text info (append ((ident->accu info) array)
 600                                      (wrap-as (i386:mem+n->accu offset))))))
 601
 602         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
 603          (let* ((type (ident->type info array))
 604                 (fields (or (type->description info type) '()))
 605                 (field-size 4) ;; FIXME:4, not fixed
 606                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
 607                           (begin
 608                             (stderr "no field:~a\n" field)
 609                             '())))
 610                 (offset (* field-size (1- (length rest))))
 611                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
 612            (append-text info (wrap-as (i386:mem+n->accu offset)))))
 613
 614         ((i-sel (ident ,field) (p-expr (ident ,array)))
 615          (let* ((type (ident->type info array))
 616                 (fields (type->description info type))
 617                 (field-size 4) ;; FIXME:4, not fixed
 618                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 619                 (text (.text info)))
 620            (append-text info (append ((ident-address->accu info) array)
 621                                      (wrap-as (i386:mem->accu))
 622                                      (wrap-as (i386:mem+n->accu offset))))))
 623
 624         ;;; FIXME: FROM INFO ...only zero?!
 625         ((p-expr (fixed ,value))
 626          (let ((value (cstring->number value)))
 627            (append-text info (wrap-as (i386:value->accu value)))))
 628
 629         ((p-expr (char ,char))
 630          (let ((char (char->integer (car (string->list char)))))
 631            (append-text info (wrap-as (i386:value->accu char)))))
 632
 633         ((p-expr (ident ,name))
 634          (append-text info ((ident->accu info) name)))
 635
 636         ((de-ref (p-expr (ident ,name)))
 637          (let* ((type (ident->type info name))
 638                 (ptr (ident->pointer info name))
 639                 (size (if (= ptr 1) (type->size info type)
 640                           4)))
 641            (append-text info (append ((ident->accu info) name)
 642                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
 643                                                   (i386:mem->accu)))))))
 644
 645         ((de-ref (post-inc (p-expr (ident ,name))))
 646          (let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
 647                 (type (ident->type info name))
 648                 (ptr (ident->pointer info name))
 649                 (size (if (= ptr 1) (type->size info type)
 650                           4)))
 651            (append-text info ((ident-add info) name size))))
 652
 653         ((de-ref ,expr)
 654          (let ((info ((expr->accu info) expr)))
 655            (append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
 656
 657         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
 658          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
 659                                    (append-text info (wrap-as (asm->hex arg0))))
 660              (let* ((text-length (length text))
 661                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
 662                                  (if (null? expressions) info
 663                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
 664                     (n (length expr-list)))
 665                (if (and (not (assoc-ref locals name))
 666                         (assoc name (.functions info)))
 667                    (append-text args-info (list `(lambda (f g ta t d)
 668                                                   (i386:call f g ta t d (+ t (function-offset ,name f)) ,n))))
 669                    (let* ((empty (clone info #:text '()))
 670                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
 671                      (append-text args-info (append (.text accu)
 672                                                     (list `(lambda (f g ta t d)
 673                                                             (i386:call-accu f g ta t d ,n))))))))))
 674
 675         ((fctn-call ,function (expr-list . ,expr-list))
 676          (let* ((text-length (length text))
 677                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
 678                              (if (null? expressions) info
 679                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
 680                 (n (length expr-list))
 681                 (empty (clone info #:text '()))
 682                 (accu ((expr->accu empty) function)))
 683            (append-text args-info (append (.text accu)
 684                                           (list `(lambda (f g ta t d)
 685                                                   (i386:call-accu f g ta t d ,n)))))))
 686
 687         ((cond-expr . ,cond-expr)
 688          ((ast->info info) `(expr-stmt ,o)))
 689
 690         ((post-inc (p-expr (ident ,name)))
 691          (let* ((type (ident->type info name))
 692                 (ptr (ident->pointer info name))
 693                 (size (if (> ptr 1) 4 1)))
 694            (append-text info (append ((ident->accu info) name)
 695                                      ((ident-add info) name size)))))
 696
 697         ((post-dec (p-expr (ident ,name)))
 698          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
 699          (append-text info (append ((ident->accu info) name)
 700                                    ((ident-add info) name -1))))
 701
 702         ((pre-inc (p-expr (ident ,name)))
 703          (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) (error "undefined identifier: " name)))
 704          (append-text info (append ((ident-add info) name 1)
 705                                    ((ident->accu info) name))))
 706
 707         ((pre-dec (p-expr (ident ,name)))
 708          (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) (error "undefined identifier: " name)))
 709          (append-text info (append ((ident-add info) name -1)
 710                                    ((ident->accu info) name))))
 711
 712         ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
 713         ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
 714         ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
 715         ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
 716         ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
 717         ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
 718         ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
 719         ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
 720         ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
 721         ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
 722
 723         ((not ,expr)
 724          (let* ((test-info ((ast->info info) expr)))
 725            (clone info #:text
 726                   (append (.text test-info)
 727                           (wrap-as (i386:accu-not)))
 728                   #:globals (.globals test-info))))
 729
 730         ((neg (p-expr (fixed ,value)))
 731          (append-text info (value->accu (- (cstring->number value)))))
 732
 733         ((neg (p-expr (ident ,name)))
 734          (append-text info (append ((ident->base info) name)
 735                                    (wrap-as (i386:value->accu 0))
 736                                    (wrap-as (i386:sub-base)))))
 737
 738         ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
 739         ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
 740         ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
 741
 742         ;; FIXME: set accu *and* flags
 743         ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
 744                                                     (i386:sub-base)
 745                                                     (i386:nz->accu)
 746                                                     (i386:accu<->stack)
 747                                                     (i386:sub-base)
 748                                                     (i386:xor-zf)
 749                                                     (i386:pop-accu))))
 750
 751         ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
 752         ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
 753         ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
 754
 755         ((or ,a ,b)
 756          (let* ((empty (clone info #:text '()))
 757                 (b-length (length (append (i386:Xjump-nz 0)
 758                                           (i386:accu-test))))
 759                 (info ((expr->accu info) a))
 760                 (info (append-text info (wrap-as (i386:accu-test))))
 761                 (info (append-text info (wrap-as (append (i386:Xjump-nz (- b-length 1))
 762                                                          (i386:accu-test)))))
 763                 (info ((expr->accu info) b))
 764                 (info (append-text info (wrap-as (i386:accu-test)))))
 765            info))
 766
 767         ((and ,a ,b)
 768          (let* ((empty (clone info #:text '()))
 769                 (b-length (length (append (i386:Xjump-z 0)
 770                                           (i386:accu-test))))
 771                 (info ((expr->accu info) a))
 772                 (info (append-text info (wrap-as (i386:accu-test))))
 773                 (info (append-text info (wrap-as (append (i386:Xjump-z (- b-length 1))
 774                                                          (i386:accu-test)))))
 775                 (info ((expr->accu info) b))
 776                 (info (append-text info (wrap-as (i386:accu-test)))))
 777            info))
 778
 779         ((cast ,cast ,o)
 780          ((expr->accu info) o))
 781
 782         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
 783          (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
 784            (append-text info ((ident-add info) name 1)))) ;; FIXME: size
 785
 786         ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
 787          (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
 788            (append-text info ((ident-add info) name -1)))) ;; FIXME: size
 789
 790         ((assn-expr ,a (op ,op) ,b)
 791          (let* ((info ((expr->accu info) b))
 792                 (info (if (equal? op "=") info
 793                           (let* ((info (append-text info (wrap-as (i386:push-accu))))
 794                                  (info ((expr->accu info) a))
 795                                  (info (append-text info (wrap-as (i386:pop-base)))))
 796                             (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
 797                                                     ((equal? op "-=") (wrap-as (i386:accu-base)))
 798                                                     ((equal? op "*=") (wrap-as (i386:accu*base)))
 799                                                     ((equal? op "/=") (wrap-as (i386:accu/base)))
 800                                                     ((equal? op "%=") (wrap-as (i386:accu%base)))
 801                                                     ((equal? op "|=") (wrap-as (i386:accu-or-base)))
 802                                                     (else (error "mescc: op ~a not supported: ~a\n" op o))))))))
 803            (pmatch a
 804              ((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
 805              ((d-sel (ident ,field) ,p-expr)
 806               (let* ((type (p-expr->type info p-expr))
 807                      (fields (type->description info type))
 808                      (size (type->size info type))
 809                      (field-size 4) ;; FIXME:4, not fixed
 810                      (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 811                      (info (append-text info (wrap-as (i386:push-accu))))
 812                      (info ((expr->accu* info) a))
 813                      (info (append-text info (wrap-as (i386:pop-base)))))
 814                 (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
 815              ;; FIXME: c&p above
 816              ((de-ref (p-expr (ident ,array)))
 817               (let* ((type (ident->type info array))
 818                      (ptr (ident->pointer info array))
 819                      (size (if (> ptr 1) 4 1)))
 820                 (append-text info (append (wrap-as (i386:accu->base))
 821                                           ((base->ident-address info) array)
 822                                           (i386:base->accu)))))
 823              ((array-ref ,index (p-expr (ident ,array)))
 824               (let* ((type (ident->type info array))
 825                      (size (type->size info type))
 826                      (info (append-text info (wrap-as (append (i386:push-accu)))))
 827                      (info ((expr->accu* info) a))
 828                      (info (append-text info (wrap-as (append (i386:pop-base))))))
 829                 (append-text info
 830                              (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
 831                                          (if (<= size 4) (wrap-as (i386:base->accu-address))
 832                                           (append
 833                                            (wrap-as (i386:base-address->accu-address))
 834                                            (wrap-as (append (i386:accu+n 4)
 835                                                             (i386:base+n 4)
 836                                                             (i386:base-address->accu-address)))
 837                                            (if (<= size 8) '()
 838                                                (wrap-as (append (i386:accu+n 4)
 839                                                                 (i386:base+n 4)
 840                                                                 (i386:base-address->accu-address)))))))))))
 841              (_ (error "expr->accu: unsupported assign: " a)))))
 842
 843         (_ (error "expr->accu: unsupported: " o))))))
 844
 845 (define (expr->base info)
 846   (lambda (o)
 847     (let* ((info (append-text info (wrap-as (i386:push-accu))))
 848            (info ((expr->accu info) o))
 849            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
 850       info)))
 851
 852 (define (binop->accu info)
 853   (lambda (a b c)
 854     (let* ((info ((expr->accu info) a))
 855            (info ((expr->base info) b)))
 856       (append-text info (wrap-as c)))))
 857
 858 (define (append-text info text)
 859   (clone info #:text (append (.text info) text)))
 860
 861 (define (wrap-as o)
 862   (list `(lambda (f g ta t d) ,(cons 'list o))))
 863
 864 (define (expr->accu* info)
 865   (lambda (o)
 866     (pmatch o
 867       ;; g_cells[<expr>]
 868       ((array-ref ,index (p-expr (ident ,array)))
 869        (let* ((info ((expr->accu info) index))
 870               (type (ident->type info array))
 871               (ptr (ident->pointer info array))
 872               (size (if (< ptr 2) (type->size info type)
 873                         4)))
 874          (append-text info (append (wrap-as (append (i386:accu->base)
 875                                                     (if (eq? size 1) '()
 876                                                         (append
 877                                                          (if (<= size 4) '()
 878                                                              (i386:accu+accu))
 879                                                          (if (<= size 8) '()
 880                                                              (i386:accu+base))
 881                                                          (i386:accu-shl 2)))))
 882                                    ((ident->base info) array)
 883                                    (wrap-as (i386:accu+base))))))
 884
 885       ;; g_cells[<expr>].type
 886       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
 887        (let* ((type (ident->type info array))
 888               (fields (or (type->description info type) '()))
 889               (field-size 4) ;; FIXME:4, not fixed
 890               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 891               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
 892          (append-text info (wrap-as (append (i386:accu+value offset))))))
 893
 894       ((d-sel (ident ,field) (p-expr (ident ,name)))
 895        (let* ((type (ident->type info name))
 896               (fields (or (type->description info type) '()))
 897               (field-size 4) ;; FIXME
 898               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 899               (text (.text info)))
 900          (append-text info (append ((ident->accu info) name)
 901                                    (wrap-as (i386:accu+value offset))))))
 902
 903       (_ (error "expr->accu*: unsupported: " o)))))
 904
 905 (define (ident->constant name value)
 906   (cons name value))
 907
 908 (define (make-type name type size description)
 909   (cons name (list type size description)))
 910
 911 (define (enum->type name fields)
 912   (make-type name 'enum 4 fields))
 913
 914 (define (struct->type name fields)
 915   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
 916
 917 (define (decl->type o)
 918   (pmatch o
 919     ((fixed-type ,type) type)
 920     ((struct-ref (ident ,name)) (list "struct" name))
 921     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
 922      (list "struct" name)) ;; FIXME
 923     ((typename ,name) name)
 924     (,name name)
 925     (_ (error "decl->type: unsupported: " o))))
 926
 927 (define (expr->global o)
 928   (pmatch o
 929     ((p-expr (string ,string)) (string->global string))
 930     ((p-expr (fixed ,value)) (int->global (cstring->number value)))
 931     (_ #f)))
 932
 933 (define (initzer->global o)
 934   (pmatch o
 935     ((initzer ,initzer) (expr->global initzer))
 936     (_ #f)))
 937
 938 (define (byte->hex o)
 939   (string->number (string-drop o 2) 16))
 940
 941 (define (asm->hex o)
 942   (let ((prefix ".byte "))
 943     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
 944         (let ((s (string-drop o (string-length prefix))))
 945           (map byte->hex (string-split s #\space))))))
 946
 947 (define (clause->jump-info info)
 948   (define (jump n)
 949     (wrap-as (i386:Xjump n)))
 950   (define (jump-nz n)
 951     (wrap-as (i386:Xjump-nz n)))
 952   (define (jump-z n)
 953     (wrap-as (i386:Xjump-z n)))
 954   (define (statement->info info body-length)
 955     (lambda (o)
 956       (pmatch o
 957         ((break) (append-text info (jump body-length)))
 958         (_ ((ast->info info) o)))))
 959   (define (test->text test)
 960     (let ((value (pmatch test
 961                    (0 0)
 962                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
 963                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
 964                    ((p-expr (fixed ,value)) (cstring->number value))
 965                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
 966                    (_ (error "case test: unsupported: " test)))))
 967       (lambda (n)
 968         (append (wrap-as (i386:accu-cmp-value value))
 969                 (jump-z (+ (length (object->list (jump 0)))
 970                            (if (= n 0) 0
 971                                (* n (length (object->list ((test->text 0) 0)))))))))))
 972   (define (cases+jump cases clause-length)
 973     (append-text info
 974                  (append
 975                   (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
 976                   (if (null? cases) '()
 977                       (jump clause-length)))))
 978   (lambda (o)
 979     (lambda (body-length)
 980       (let loop ((o o) (cases '()) (clause #f))
 981         (pmatch o
 982           ((case ,test ,statement)
 983            (loop statement (append cases (list (test->text test))) clause))
 984           ((default ,statement)
 985            (loop statement cases clause))
 986           ((compd-stmt (block-item-list))
 987            (loop '() cases clause))
 988           ((compd-stmt (block-item-list . ,elements))
 989            (let ((clause (or clause (cases+jump cases 0))))
 990              (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
 991                    ((statement->info clause body-length) (car elements)))))
 992           (()
 993            (let* ((cases-length (length (.text (cases+jump cases 0))))
 994                   (clause-text (list-tail (.text clause) cases-length))
 995                   (clause-length (length (object->list clause-text))))
 996              (clone clause #:text
 997                     (append (.text (cases+jump cases clause-length))
 998                             clause-text))))
 999           (_
1000            (let ((clause (or clause (cases+jump cases 0))))
1001              (loop '() cases
1002                    ((statement->info clause body-length) o)))))))))
1003
1004 (define (test->jump->info info)
1005   (define (jump type . test)
1006     (lambda (o)
1007       (let* ((text (.text info))
1008              (info (clone info #:text '()))
1009              (info ((ast->info info) o))
1010              (jump-text (lambda (body-length)
1011                           (wrap-as (type body-length)))))
1012         (lambda (body-length)
1013           (clone info #:text
1014                  (append text
1015                          (.text info)
1016                          (if (null? test) '() (car test))
1017                          (jump-text body-length)))))))
1018   (lambda (o)
1019     (pmatch o
1020       ;; unsigned
1021       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1022       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
1023       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1024       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1025
1026       ((le ,a ,b) ((jump i386:Xjump-g) o))
1027       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1028       ((ge ,a ,b) ((jump i386:Xjump-g) o))
1029       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1030
1031       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1032       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1033       ((not _) ((jump i386:Xjump-z) o))
1034       ((and ,a ,b)
1035        (let* ((globals (.globals info))
1036               (text (.text info))
1037               (info (clone info #:text '()))
1038
1039               (a-jump ((test->jump->info info) a))
1040               (a-text (.text (a-jump 0)))
1041               (a-length (length (object->list a-text)))
1042
1043               (b-jump ((test->jump->info info) b))
1044               (b-text (.text (b-jump 0)))
1045               (b-length (length (object->list b-text))))
1046
1047          (lambda (body-length)
1048            (let* ((info (append-text info text))
1049                   (a-info (a-jump (+ b-length body-length)))
1050                   (info (append-text info (.text a-info)))
1051                   (b-info (b-jump body-length))
1052                   (info (append-text info (.text b-info))))
1053             (clone info
1054                    #:globals (append globals
1055                                      (list-tail (.globals a-info) (length globals))
1056                                      (list-tail (.globals b-info) (length globals))))))))
1057
1058       ((or ,a ,b)
1059        (let* ((globals (.globals info))
1060               (text (.text info))
1061               (info (clone info #:text '()))
1062
1063               (a-jump ((test->jump->info info) a))
1064               (a-text (.text (a-jump 0)))
1065               (a-length (length (object->list a-text)))
1066
1067               (jump-text (wrap-as (i386:Xjump 0)))
1068               (jump-length (length (object->list jump-text)))
1069
1070               (b-jump ((test->jump->info info) b))
1071               (b-text (.text (b-jump 0)))
1072               (b-length (length (object->list b-text)))
1073
1074               (jump-text (wrap-as (i386:Xjump b-length))))
1075
1076          (lambda (body-length)
1077            (let* ((info (append-text info text))
1078                   (a-info (a-jump jump-length))
1079                   (info (append-text info (.text a-info)))
1080                   (info (append-text info jump-text))
1081                   (b-info (b-jump body-length))
1082                   (info (append-text info (.text b-info))))
1083             (clone info
1084                    #:globals (append globals
1085                                      (list-tail (.globals a-info) (length globals))
1086                                      (list-tail (.globals b-info) (length globals))))))))
1087
1088       ((array-ref . _) ((jump i386:jump-byte-z
1089                               (wrap-as (i386:accu-zero?))) o))
1090
1091       ((de-ref _) ((jump i386:jump-byte-z
1092                          (wrap-as (i386:accu-zero?))) o))
1093
1094       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1095        ((jump i386:Xjump-z
1096               (append
1097                ((ident->accu info) name)
1098                (wrap-as (i386:accu-zero?)))) o))
1099
1100       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1101
1102 (define (cstring->number s)
1103   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1104         ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1105         ((string-prefix? "0" s) (string->number s 8))
1106         (else (string->number s))))
1107
1108 (define (struct-field o)
1109   (pmatch o
1110     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1111                 (comp-declr-list (comp-declr (ident ,name))))
1112      (cons type name))
1113     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1114      (cons type name))
1115     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1116      (cons type name))
1117     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list (param-decl (decl-spec-list (type-spec (void)))))))))
1118      (cons type name)) ;; FIXME function / int
1119     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1120      (cons type name)) ;; FIXME: ptr/char
1121     (_ (error "struct-field: unsupported: " o))))
1122
1123 (define (ast->type o)
1124   (pmatch o
1125     ((fixed-type ,type)
1126      type)
1127     ((struct-ref (ident ,type))
1128      (list "struct" type))
1129     (_ (stderr "SKIP: type=~s\n" o)
1130        "int")))
1131
1132 (define i386:type-alist
1133   '(("char" . (builtin 1 #f))
1134     ("short" . (builtin 2 #f))
1135     ("int" . (builtin 4 #f))))
1136
1137 (define (type->size info o)
1138   (pmatch o
1139     ((decl-spec-list (type-spec (fixed-type ,type)))
1140      (type->size info type))
1141     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1142      (type->size info type))
1143     (_ (let ((type (assoc-ref (.types info) o)))
1144          (if type (cadr type)
1145              (error "type->size: unsupported: " o))))))
1146
1147 (define (ident->decl info o)
1148   (or (assoc-ref (.locals info) o)
1149       (assoc-ref (.globals info) o)
1150       (begin
1151         (stderr "NO IDENT: ~a\n" o)
1152         (assoc-ref (.functions info) o))))
1153
1154 (define (ident->type info o)
1155   (and=> (ident->decl info o) car))
1156
1157 (define (ident->pointer info o)
1158   (let ((local (assoc-ref (.locals info) o)))
1159     (if local (local:pointer local)
1160         (or (and=> (ident->decl info o) global:pointer) 0))))
1161
1162 (define (p-expr->type info o)
1163   (pmatch o
1164     ((p-expr (ident ,name)) (ident->type info name))
1165     ((array-ref ,index (p-expr (ident ,array)))
1166      (ident->type info array))
1167     (_ (error "p-expr->type: unsupported: " o))))
1168
1169 (define (type->description info o)
1170   (pmatch o
1171     ((decl-spec-list (type-spec (fixed-type ,type)))
1172      (type->description info type))
1173     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1174      (type->description info type))
1175     (_ (let ((type (assoc-ref (.types info) o)))
1176          (if (not type) (stderr "TYPES=~s\n" (.types info)))
1177          (if type (caddr type)
1178              (error "type->description: unsupported:" o))))))
1179
1180 (define (local? o) ;; formals < 0, locals > 0
1181   (positive? (local:id o)))
1182
1183 (define (statements->clauses statements)
1184   (let loop ((statements statements) (clauses '()))
1185     (if (null? statements) clauses
1186         (let ((s (car statements)))
1187           (pmatch s
1188             ((case ,test (compd-stmt (block-item-list . _)))
1189              (loop (cdr statements) (append clauses (list s))))
1190             ((case ,test (break))
1191              (loop (cdr statements) (append clauses (list s))))
1192             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1193
1194             ((case ,test ,statement)
1195              (let loop2 ((statement statement) (heads `((case ,test))))
1196                (define (heads->case heads statement)
1197                  (if (null? heads) statement
1198                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1199                (pmatch statement
1200                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1201                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1202                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1203                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1204                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1205                           (let ((s (car statements)))
1206                             (pmatch s
1207                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1208                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1209                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1210                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1211             ((default (compd-stmt (block-item-list _)))
1212              (loop (cdr statements) (append clauses (list s))))
1213             ((default . ,statement)
1214              (let loop2 ((statements (cdr statements)) (c statement))
1215                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1216                    (let ((s (car statements)))
1217                      (pmatch s
1218                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1219                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1220                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1221                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1222
1223                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1224             (_ (error "statements->clauses: unsupported:" s)))))))
1225
1226 (define (ast->info info)
1227   (lambda (o)
1228     (let ((functions (.functions info))
1229           (globals (.globals info))
1230           (locals (.locals info))
1231           (constants (.constants info))
1232           (text (.text info)))
1233       (define (add-local locals name type pointer)
1234         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1235                        (1+ (local:id (cdar locals)))))
1236                (locals (cons (make-local name type pointer id) locals)))
1237           locals))
1238       (define (declare name)
1239         (if (member name functions) info
1240             (clone info #:functions (cons (cons name #f) functions))))
1241       (pmatch o
1242         (((trans-unit . _) . _)
1243          ((ast-list->info info)  o))
1244         ((trans-unit . ,elements)
1245          ((ast-list->info info) elements))
1246         ((fctn-defn . _) ((function->info info) o))
1247         ((comment . _) info)
1248         ((cpp-stmt (define (name ,name) (repl ,value)))
1249          info)
1250
1251         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1252          info)
1253
1254         ((break)
1255          (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text)))))))
1256
1257         ;; FIXME: expr-stmt wrapper?
1258         (trans-unit info)
1259         ((expr-stmt) info)
1260
1261         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1262
1263         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1264          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1265                                    (append-text info (wrap-as (asm->hex arg0))))
1266              (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1267                (append-text info (wrap-as (i386:accu-zero?))))))
1268
1269         ((if ,test ,body)
1270          (let* ((text-length (length text))
1271
1272                 (test-jump->info ((test->jump->info info) test))
1273                 (test+jump-info (test-jump->info 0))
1274                 (test-length (length (.text test+jump-info)))
1275
1276                 (body-info ((ast->info test+jump-info) body))
1277                 (text-body-info (.text body-info))
1278                 (body-text (list-tail text-body-info test-length))
1279                 (body-length (length (object->list body-text)))
1280
1281                 (text+test-text (.text (test-jump->info body-length)))
1282                 (test-text (list-tail text+test-text text-length)))
1283
1284            (clone info #:text
1285                   (append text
1286                           test-text
1287                           body-text)
1288                   #:globals (.globals body-info))))
1289
1290         ((if ,test ,then ,else)
1291          (let* ((text-length (length text))
1292
1293                 (test-jump->info ((test->jump->info info) test))
1294                 (test+jump-info (test-jump->info 0))
1295                 (test-length (length (.text test+jump-info)))
1296
1297                 (then-info ((ast->info test+jump-info) then))
1298                 (text-then-info (.text then-info))
1299                 (then-text (list-tail text-then-info test-length))
1300                 (then-jump-text (wrap-as (i386:Xjump 0)))
1301                 (then-jump-length (length (object->list then-jump-text)))
1302                 (then-length (+ (length (object->list then-text)) then-jump-length))
1303
1304                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1305                 (else-info ((ast->info then+jump-info) else))
1306                 (text-else-info (.text else-info))
1307                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1308                 (else-length (length (object->list else-text)))
1309
1310                 (text+test-text (.text (test-jump->info then-length)))
1311                 (test-text (list-tail text+test-text text-length))
1312                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1313
1314            (clone info #:text
1315                   (append text
1316                           test-text
1317                           then-text
1318                           then-jump-text
1319                           else-text)
1320                   #:globals (append (.globals then-info)
1321                                     (list-tail (.globals else-info) (length globals))))))
1322
1323         ;; Hmm?
1324         ((expr-stmt (cond-expr ,test ,then ,else))
1325          (let* ((text-length (length text))
1326
1327                 (test-jump->info ((test->jump->info info) test))
1328                 (test+jump-info (test-jump->info 0))
1329                 (test-length (length (.text test+jump-info)))
1330
1331                 (then-info ((ast->info test+jump-info) then))
1332                 (text-then-info (.text then-info))
1333                 (then-text (list-tail text-then-info test-length))
1334                 (then-length (length (object->list then-text)))
1335
1336                 (jump-text (wrap-as (i386:Xjump 0)))
1337                 (jump-length (length (object->list jump-text)))
1338
1339                 (test+then+jump-info
1340                  (clone then-info
1341                         #:text (append (.text then-info) jump-text)))
1342
1343                 (else-info ((ast->info test+then+jump-info) else))
1344                 (text-else-info (.text else-info))
1345                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1346                 (else-length (length (object->list else-text)))
1347
1348                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1349                 (test-text (list-tail text+test-text text-length))
1350                 (jump-text (wrap-as (i386:Xjump else-length))))
1351
1352            (clone info #:text
1353                   (append text
1354                           test-text
1355                           then-text
1356                           jump-text
1357                           else-text)
1358                   #:globals (.globals else-info))))
1359
1360         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1361          (let* ((clauses (statements->clauses statements))
1362                 (expr ((expr->accu info) expr))
1363                 (empty (clone info #:text '()))
1364                 (clause-infos (map (clause->jump-info empty) clauses))
1365                 (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
1366                 (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
1367                               (if (null? clauses) info
1368                                   (let ((c-j ((clause->jump-info info) (car clauses))))
1369                                     (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1370            clauses-info))
1371
1372         ((for ,init ,test ,step ,body)
1373          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1374
1375                 (info ((ast->info info) init))
1376
1377                 (init-text (.text info))
1378                 (init-locals (.locals info))
1379                 (info (clone info #:text '()))
1380
1381                 (body-info ((ast->info info) body))
1382                 (body-text (.text body-info))
1383                 (body-length (length (object->list body-text)))
1384
1385                 (step-info ((expr->accu info) step))
1386                 (step-text (.text step-info))
1387                 (step-length (length (object->list step-text)))
1388
1389                 (test-jump->info ((test->jump->info info) test))
1390                 (test+jump-info (test-jump->info 0))
1391                 (test-length (length (object->list (.text test+jump-info))))
1392
1393                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1394
1395                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1396                 (jump-length (length (object->list jump-text)))
1397
1398                 (test-text (.text (test-jump->info jump-length))))
1399
1400            (clone info #:text
1401                   (append text
1402                           init-text
1403                           skip-body-text
1404                           body-text
1405                           step-text
1406                           test-text
1407                           jump-text)
1408                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1409                   #:locals locals)))
1410
1411         ((while ,test ,body)
1412          (let* ((skip-info (lambda (body-length test-length)
1413                              (clone info
1414                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1415                                     #:break (cons (+ (length (object->list text)) body-length test-length
1416                                                      (length (i386:Xjump 0)))
1417                                                   (.break info)))))
1418                 (text (.text (skip-info 0 0)))
1419                 (text-length (length text))
1420                 (body-info (lambda (body-length test-length)
1421                              ((ast->info (skip-info body-length test-length)) body)))
1422
1423                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1424                 (body-length (length (object->list body-text)))
1425
1426                 (empty (clone info #:text '()))
1427                 (test-jump->info ((test->jump->info empty) test))
1428                 (test+jump-info (test-jump->info 0))
1429                 (test-length (length (object->list (.text test+jump-info))))
1430
1431                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1432                 (jump-length (length (object->list jump-text)))
1433
1434                 (test-text (.text (test-jump->info jump-length)))
1435
1436                 (body-info (body-info body-length (length (object->list test-text)))))
1437
1438            (clone info #:text
1439                   (append
1440                    (.text body-info)
1441                    test-text
1442                    jump-text)
1443                   #:globals (.globals body-info))))
1444
1445         ((do-while ,body ,test)
1446          (let* ((text-length (length text))
1447
1448                 (body-info ((ast->info info) body))
1449                 (body-text (list-tail (.text body-info) text-length))
1450                 (body-length (length (object->list body-text)))
1451
1452                 (empty (clone info #:text '()))
1453                 (test-jump->info ((test->jump->info empty) test))
1454                 (test+jump-info (test-jump->info 0))
1455                 (test-length (length (object->list (.text test+jump-info))))
1456
1457                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1458                 (jump-length (length (object->list jump-text)))
1459
1460                 (test-text (.text (test-jump->info jump-length))))
1461            (clone info #:text
1462                   (append
1463                    (.text body-info)
1464                    test-text
1465                    jump-text)
1466                   #:globals (.globals body-info))))
1467
1468         ((labeled-stmt (ident ,label) ,statement)
1469          (let ((info (append-text info (list label))))
1470            ((ast->info info) statement)))
1471
1472         ((goto (ident ,label))
1473          (let* ((jump (lambda (n) (i386:XXjump n)))
1474                 (offset (+ (length (jump 0)) (length (object->list text)))))
1475            (append-text info (append
1476                               (list `(lambda (f g ta t d)
1477                                       (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
1478
1479         ((return ,expr)
1480          (let ((info ((expr->accu info) expr)))
1481            (append-text info (append (wrap-as (i386:ret))))))
1482
1483         ;; DECL
1484
1485         ;; int i;
1486         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1487          (if (.function info)
1488              (clone info #:locals (add-local locals name type 0))
1489              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1490
1491         ;; enum e i;
1492         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1493          (let ((type "int")) ;; FIXME
1494            (if (.function info)
1495                (clone info #:locals (add-local locals name type 0))
1496                (clone info #:globals (append globals (list (ident->global name type 0 0)))))))
1497
1498         ;; int i = 0;
1499         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1500          (let ((value (cstring->number value)))
1501            (if (.function info)
1502                (let* ((locals (add-local locals name type 0))
1503                       (info (clone info #:locals locals)))
1504                  (append-text info ((value->ident info) name value)))
1505                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1506
1507         ;; char c = 'A';
1508         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1509          (if (not (.function info)) (error "ast->info: unsupported: " o))
1510          (let* ((locals (add-local locals name type 0))
1511                 (info (clone info #:locals locals))
1512                 (value (char->integer (car (string->list value)))))
1513            (append-text info ((value->ident info) name value))))
1514
1515         ;; int i = -1;
1516         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1517          (let ((value (- (cstring->number value))))
1518            (if (.function info)
1519                (let* ((locals (add-local locals name type 0))
1520                       (info (clone info #:locals locals)))
1521                  (append-text info ((value->ident info) name value)))
1522                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1523
1524         ;; int i = argc;
1525         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1526          (if (not (.function info)) (error "ast->info: unsupported: " o))
1527          (let* ((locals (add-local locals name type 0))
1528                 (info (clone info #:locals locals)))
1529            (append-text info (append ((ident->accu info) local)
1530                                      ((accu->ident info) name)))))
1531
1532         ;; char *p = "foo";
1533         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1534          (if (.function info)
1535              (let* ((locals (add-local locals name type 1))
1536                     (globals (append globals (list (string->global string))))
1537                     (info (clone info #:locals locals #:globals globals)))
1538                (append-text info (append
1539                                   (list `(lambda (f g ta t d)
1540                                           (append
1541                                            (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
1542                                   ((accu->ident info) name))))
1543              (let* ((global (string->global string))
1544                     (globals (append globals (list global)))
1545                     (size 4)
1546                     (global (make-global name type 1 (string->list (make-string size #\nul))))
1547                     (globals (append globals (list global)))
1548                     (info (clone info #:globals globals)))
1549                (clone info #:init
1550                       (append
1551                        (.init info)
1552                        (list
1553                         `(lambda (f g ta t d data)
1554                            (let (((here (data-offset ,name g))))
1555                              (append
1556                               (list-head data here)
1557                               (initzer->data f g ta t d '(initzer (p-expr (string ,string))))
1558                               (list-tail data (+ here ,size)))))))))))
1559
1560         ;; char const *p;
1561         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1562          (if (.function info)
1563              (let* ((locals (add-local locals name type 1))
1564                     (info (clone info #:locals locals)))
1565                (append-text info (append (wrap-as (i386:value->accu 0))
1566                                          ((accu->ident info) name))))
1567              (let ((globals (append globals (list (ident->global name type 1 0)))))
1568                (clone info #:globals globals))))
1569
1570         ;; char *p;
1571         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1572          (if (.function info)
1573              (let* ((locals (add-local locals name type 1))
1574                     (info (clone info #:locals locals)))
1575                (append-text info (append (wrap-as (i386:value->accu 0))
1576                                          ((accu->ident info) name))))
1577              (let ((globals (append globals (list (ident->global name type 1 0)))))
1578                (clone info #:globals globals))))
1579
1580         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1581          (let ((value (cstring->number value)))
1582            (if (.function info)
1583                (let* ((locals (add-local locals name type 1))
1584                       (info (clone info #:locals locals)))
1585                  (append-text info (append (wrap-as (i386:value->accu value))
1586                                            ((accu->ident info) name))))
1587                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1588
1589         ;; char **p;
1590         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1591          (if (.function info)
1592              (let* ((locals (add-local locals name type 2))
1593                     (info (clone info #:locals locals)))
1594                (append-text info (append (wrap-as (i386:value->accu 0))
1595                                          ((accu->ident info) name))))
1596              (let ((globals (append globals (list (ident->global name type 2 0)))))
1597                (clone info #:globals globals))))
1598
1599         ;; char **p = 0;
1600         ;;((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (fixed ,value)))))))
1601
1602         ;; char **p = g_environment;
1603         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
1604          (if (.function info)
1605              (let* ((locals (add-local locals name type 2))
1606                     (info (clone info #:locals locals)))
1607                (append-text info (append
1608                                   ((ident->accu info) b)
1609                                   ((accu->ident info) name))))
1610              (let* ((globals (append globals (list (ident->global name type 2 0))))
1611                     (value (assoc-ref constants b)))
1612                (clone info
1613                       #:globals globals
1614                       #:init (append (.init info)
1615                                      (list
1616                                       `(lambda (f g ta t d data)
1617                                          (let ((here (data-offset ,name g)))
1618                                            (append
1619                                             (list-head data here)
1620                                             (initzer->data f g ta t d '(p-expr (fixed ,value)))
1621                                             (list-tail data (+ here 4)))))))))))
1622
1623         ;; struct foo bar[2];
1624         ;; char arena[20000];
1625         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1626          (let ((type (ast->type type)))
1627            (if (.function info)
1628                (let* ((local (car (add-local locals name type -1)))
1629                       (count (string->number count))
1630                       (size (type->size info type))
1631                       (local (make-local name type -1 (+ (local:id local) (* count size))))
1632                       (locals (cons local locals))
1633                       (info (clone info #:locals locals)))
1634                  info)
1635                (let* ((globals (.globals info))
1636                       (count (cstring->number count))
1637                       (size (type->size info type))
1638                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1639                       (globals (append globals (list array))))
1640                  (clone info #:globals globals)))))
1641
1642         ;; char* a[10];
1643         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1644          (let ((type (ast->type type)))
1645            (if (.function info)
1646                (let* ((local (car (add-local locals name type -1)))
1647                       (count (string->number count))
1648                       (size (type->size info type))
1649                       (local (make-local name type 1 (+ (local:id local) (* count size))))
1650                       (locals (cons local locals))
1651                       (info (clone info #:locals locals)))
1652                  info)
1653                (let* ((globals (.globals info))
1654                       (count (cstring->number count))
1655                       (size (type->size info type))
1656                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1657                       (globals (append globals (list array))))
1658                  (clone info #:globals globals)))))
1659
1660         ;; struct foo bar;
1661         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1662          (if (.function info)
1663              (let* ((locals (add-local locals name `("struct" ,type) 1))
1664                     (info (clone info #:locals locals)))
1665                info)
1666              (let* ((size (type->size info (list "struct" type)))
1667                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1668                     (globals (append globals (list global)))
1669                     (info (clone info #:globals globals)))
1670                info)))
1671
1672         ;;struct scm *g_cells = (struct scm*)arena;
1673         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
1674          (if (.function info)
1675              (let* ((locals (add-local locals name `("struct" ,type) 1))
1676                     (info (clone info #:locals locals)))
1677                (append-text info (append ((ident->accu info) name)
1678                                          ((accu->ident info) value)))) ;; FIXME: deref?
1679              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1680                     (info (clone info #:globals globals)))
1681                (append-text info (append ((ident->accu info) name)
1682                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1683
1684
1685         ;; SCM tmp;
1686         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1687          (if (.function info)
1688              (clone info #:locals (add-local locals name type 0))
1689              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1690
1691         ;; SCM g_stack = 0;
1692         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1693          (let ((value (cstring->number value)))
1694            (if (.function info)
1695                (let* ((locals (add-local locals name type 0))
1696                       (info (clone info #:locals locals)))
1697                  (append-text info ((value->ident info) name value)))
1698                (let ((globals (append globals (list (ident->global name type 0 value)))))
1699                  (clone info #:globals globals)))))
1700
1701         ;; SCM g_stack = 0; // comment
1702         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1703          ((ast->info info) (list-head o (- (length o) 1))))
1704
1705         ;; SCM i = argc;
1706         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1707          (if (.function info)
1708              (let* ((locals (add-local locals name type 0))
1709                     (info (clone info #:locals locals)))
1710                (append-text info (append ((ident->accu info) local)
1711                                          ((accu->ident info) name))))
1712              (let* ((globals (append globals (list (ident->global name type 0 0))))
1713                     (info (clone info #:globals globals)))
1714                (append-text info (append ((ident->accu info) local)
1715                                          ((accu->ident info) name))))))
1716
1717         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1718         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)) (initzer ,initzer))))
1719          (let* ((locals (add-local locals name type 1))
1720                 (info (clone info #:locals locals))
1721                 (empty (clone info #:text '()))
1722                 (accu ((expr->accu empty) initzer)))
1723            (clone info
1724                   #:text
1725                   (append text
1726                           (.text accu)
1727                           ((accu->ident info) name)
1728                           (list `(lambda (f g ta t d)
1729                                   (append (i386:value->base ta)
1730                                           (i386:accu+base)))))
1731                   #:locals locals)))
1732
1733         ;; char *p = (char*)g_cells;
1734         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
1735          (if (.function info)
1736              (let* ((locals (add-local locals name type 1))
1737                     (info (clone info #:locals locals)))
1738                (append-text info (append ((ident->accu info) value)
1739                                          ((accu->ident info) name))))
1740              (let* ((globals (append globals (list (ident->global name type 1 0)))))
1741                (clone info
1742                       #:globals globals
1743                       #:init (append (.init info)
1744                                      (list
1745                                       `(lambda (f g ta t d data)
1746                                          (let ((here (data-offset ,name g))
1747                                                (there (data-offset ,value g)))
1748                                            (append
1749                                             (list-head data here)
1750                                             ;; FIXME: type
1751                                             ;; char *x = arena;
1752                                             (int->bv32 (+ d (data-offset ,value g)))
1753                                             ;; char *y = x;
1754                                             ;;(list-head (list-tail data there) 4)
1755                                             (list-tail data (+ here 4)))))))))))
1756
1757         ;; char *p = g_cells;
1758         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1759          (let ((type (decl->type type)))
1760            (if (.function info)
1761                (let* ((locals (add-local locals name type  1))
1762                       (info (clone info #:locals locals)))
1763                  (append-text info (append ((ident->accu info) value)
1764                                            ((accu->ident info) name))))
1765                (let* ((globals (append globals (list (ident->global name type 1 0)))))
1766                  (clone info
1767                         #:globals globals
1768                         #:init (append (.init info)
1769                                        (list `(lambda (f g ta t d data)
1770                                                 (let ((here (data-offset ,name g)))
1771                                                   (append
1772                                                    (list-head data here)
1773                                                    ;; FIXME: type
1774                                                    ;; char *x = arena;p
1775                                                    (int->bv32 (+ d (data-offset ,value g)))
1776                                                    (list-tail data (+ here 4))))))))))))
1777
1778         ;; enum
1779         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1780          (let ((type (enum->type name fields))
1781                (constants (let loop ((fields fields) (i 0) (constants constants))
1782                             (if (null? fields) constants
1783                                 (let* ((field (car fields))
1784                                        (name (pmatch field
1785                                                ((enum-defn (ident ,name) . _) name)))
1786                                        (i (pmatch field
1787                                            ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
1788                                            ((enum-defn ,name) i))))
1789                                   (loop (cdr fields)
1790                                         (1+ i)
1791                                         (append constants (list (ident->constant name i)))))))))
1792            (clone info
1793                   #:types (append (.types info) (list type))
1794                   #:constants (append constants (.constants info)))))
1795
1796         ;; struct
1797         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1798          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1799            (clone info #:types (append (.types info) (list type)))))
1800
1801         ;; struct foo {} bar;
1802         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1803                (init-declr-list (init-declr (ident ,name))))
1804          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1805            ((ast->info info)
1806             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1807
1808         ;; struct foo* bar = expr;
1809          ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1810          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1811                                      (info (clone info #:locals locals)))
1812                  (append-text info (append ((ident-address->accu info) value)
1813                                            ((accu->ident info) name))))
1814              (error "ast->info: unsupported global:" o)))
1815
1816         ;; char *p = &bla;
1817         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1818          (let ((type (decl->type type)))
1819            (if (.function info)
1820                (let* ((locals (add-local locals name type 1))
1821                       (info (clone info #:locals locals)))
1822                  (append-text info (append ((ident-address->accu info) value)
1823                                            ((accu->ident info) name))))
1824                (error "TODO" o))))
1825
1826         ;; char **p = &bla;
1827         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1828          (let ((type (decl->type type)))
1829            (if (.function info)
1830                (let* ((locals (add-local locals name type 2))
1831                       (info (clone info #:locals locals)))
1832                  (append-text info (append ((ident-address->accu info) value)
1833                                            ((accu->ident info) name))))
1834                (error "TODO" o))))
1835
1836         ;; char *p = bla[0];
1837         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (array-ref ,index (p-expr (ident ,array)))))))
1838          (if (.function info)
1839              (let* ((locals (add-local locals name type 1))
1840                     (info (clone info #:locals locals))
1841                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1842                (append-text info ((accu->ident info) name)))
1843              (error "TODO" o)))
1844
1845         ;; char *foo = &bar[0];
1846         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (array-ref ,index (p-expr (ident ,array))))))))
1847          (if (.function info)
1848              (let* ((locals (add-local locals name type 1))
1849                     (info (clone info #:locals locals))
1850                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1851                (append-text info ((accu->ident info) name)))
1852              (error "TODO" o)))
1853
1854         ;; char *p = *bla;
1855         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (de-ref (p-expr (ident ,value)))))))
1856          (if (.function info)
1857              (let* ((locals (add-local locals name type 1))
1858                     (info (clone info #:locals locals))
1859                     (local (assoc-ref (.locals info) name)))
1860                (append-text info (append ((ident->accu info) value)
1861                                          (wrap-as (i386:mem->accu))
1862                                          ((accu->ident info) name))))
1863              (error "TODO" o)))
1864
1865         ;; DECL
1866         ;; char *bla[] = {"a", "b"};
1867         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
1868          (let* ((type (decl->type type))
1869                 (entries (map initzer->global initzers))
1870                 (entry-size 4)
1871                 (size (* (length entries) entry-size))
1872                 (initzers (map (initzer->non-const info) initzers)))
1873            (if (.function info)
1874                (error "TODO: <type> x[] = {};" o)
1875                (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1876                       (globals (append globals entries (list global)))
1877                       (info (clone info #:globals globals)))
1878                  (clone info #:init
1879                         (append
1880                          (.init info)
1881                          (list
1882                           `(lambda (f g ta t d data)
1883                              (let ((here (data-offset ,name g)))
1884                                (append
1885                                 (list-head data here)
1886                                 (append-map
1887                                  (lambda (i)
1888                                    (initzer->data f g ta t d i))
1889                                  ',initzers)
1890                                 (list-tail data (+ here ,size))))))))))))
1891
1892         ;;
1893         ;; struct f = {...};
1894         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1895          (let* ((type (decl->type type))
1896                 (fields (type->description info type))
1897                 (size (type->size info type))
1898                 (field-size 4)  ;; FIXME:4, not fixed
1899                 (initzers (map (initzer->non-const info) initzers)))
1900            (if (.function info)
1901                (let* ((globals (append globals (filter-map initzer->global initzers)))
1902                       (locals (let loop ((fields (cdr fields)) (locals locals))
1903                                 (if (null? fields) locals
1904                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1905                       (locals (add-local locals name type -1))
1906                       (info (clone info #:locals locals #:globals globals))
1907                       (empty (clone info #:text '())))
1908                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1909                    (if (null? fields) info
1910                        (let ((offset (* field-size (car fields)))
1911                              (initzer (car initzers)))
1912                          (loop (cdr fields) (cdr initzers)
1913                                (clone info #:text
1914                                       (append
1915                                        (.text info)
1916                                        ((ident->accu info) name)
1917                                        (wrap-as (append (i386:accu->base)))
1918                                        (.text ((expr->accu empty) initzer))
1919                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1920                (let* ((globals (append globals (filter-map initzer->global initzers)))
1921                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1922                       (globals (append globals (list global)))
1923                       (info (clone info #:globals globals))
1924                       (field-size 4))
1925                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1926                    (if (null? fields) info
1927                        (let ((offset (* field-size (car fields)))
1928                              (initzer (car initzers)))
1929                          (loop (cdr fields) (cdr initzers)
1930                                (clone info #:init
1931                                       (append
1932                                        (.init info)
1933                                        (list
1934                                         `(lambda (f g ta t d data)
1935                                            (let ((here (data-offset ,name g)))
1936                                              (append
1937                                               (list-head data (+ here ,offset))
1938                                               (initzer->data f g ta t d ',(car initzers))
1939                                               (list-tail data (+ here ,offset ,field-size))))))))))))))))
1940
1941
1942         ;;char cc = g_cells[c].cdr;  ==> generic?
1943         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1944          (let ((type (decl->type type))
1945                (initzer ((initzer->non-const info) initzer)))
1946            (if (.function info)
1947                (let* ((locals (add-local locals name type 0))
1948                       (info (clone info #:locals locals)))
1949                  (clone info #:text
1950                         (append (.text ((expr->accu info) initzer))
1951                                 ((accu->ident info) name))))
1952                (let* ((globals (append globals (list (ident->global name type 1 0)))))
1953                  (clone info
1954                         #:globals globals
1955                         #:init (append (.init info)
1956                                        (list
1957                                         `(lambda (f g ta t d data)
1958                                            (let ((here (data-offset ,name g)))
1959                                              (append
1960                                               (list-head data here)
1961                                               (initzer->data f g ta t d ',initzer)
1962                                               (list-tail data (+ here 4))))))))))))
1963
1964
1965         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1966          (declare name))
1967
1968         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1969          (declare name))
1970
1971         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1972          (let ((types (.types info)))
1973            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1974
1975         ;; int foo ();
1976         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1977          (declare name))
1978
1979         ;; void foo ();
1980         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1981          (declare name))
1982
1983         ;; void foo (*);
1984         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1985          (declare name))
1986
1987         ;; char const* itoa ();
1988         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1989          (declare name))
1990
1991         ;; char *strcpy ();
1992         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1993          (declare name))
1994
1995         ;; printf (char const* format, ...)
1996         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1997          info)
1998
1999         ;; int i = 0, j = 0;
2000         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2001          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2002            (if (null? inits) info
2003                (loop (cdr inits)
2004                      ((ast->info info)
2005                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2006
2007         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2008          (format (current-error-port) "SKIP: typedef=~s\n" o)
2009          info)
2010
2011         ((decl (@ ,at))
2012          (format (current-error-port) "SKIP: at=~s\n" o)
2013          info)
2014
2015         ((decl . _) (error "ast->info: unsupported: " o))
2016
2017         ;; ...
2018         ((gt . _) ((expr->accu info) o))
2019         ((ge . _) ((expr->accu info) o))
2020         ((ne . _) ((expr->accu info) o))
2021         ((eq . _) ((expr->accu info) o))
2022         ((le . _) ((expr->accu info) o))
2023         ((lt . _) ((expr->accu info) o))
2024         ((lshift . _) ((expr->accu info) o))
2025         ((rshift . _) ((expr->accu info) o))
2026
2027         ;; EXPR
2028         ((expr-stmt ,expression)
2029          (let ((info ((expr->accu info) expression)))
2030            (append-text info (wrap-as (i386:accu-zero?)))))
2031
2032         ;; FIXME: why do we get (post-inc ...) here
2033         ;; (array-ref
2034         (_ (let ((info ((expr->accu info) o)))
2035              (append-text info (wrap-as (i386:accu-zero?)))))))))
2036
2037 (define (initzer->non-const info)
2038   (lambda (o)
2039     (pmatch o
2040       ((initzer (p-expr (ident ,name)))
2041        (let ((value (assoc-ref (.constants info) name)))
2042          `(initzer (p-expr (fixed ,(number->string value))))))
2043       (_ o))))
2044
2045 (define (initzer->data f g ta t d o)
2046   (pmatch o
2047     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2048     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2049     ((initzer (ref-to (p-expr (ident ,name))))
2050      (int->bv32 (+ ta (function-offset name f))))
2051     ((initzer (p-expr (string ,string)))
2052      (int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
2053     (_ (error "initzer->data: unsupported: " o))))
2054
2055 (define (.formals o)
2056   (pmatch o
2057     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2058     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2059     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2060     (_ (error ".formals: " o))))
2061
2062 (define (formal->text n)
2063   (lambda (o i)
2064     ;;(i386:formal i n)
2065     '()
2066     ))
2067
2068 (define (formals->text o)
2069   (pmatch o
2070     ((param-list . ,formals)
2071      (let ((n (length formals)))
2072        (wrap-as (append (i386:function-preamble)
2073                         (append-map (formal->text n) formals (iota n))
2074                         (i386:function-locals)))))
2075     (_ (error "formals->text: unsupported: " o))))
2076
2077 (define (formal:ptr o)
2078   (pmatch o
2079     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2080      0)
2081     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2082      2)
2083     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2084      1)
2085     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2086      1)
2087     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2088      2)
2089     (_
2090      (stderr "formal:ptr[~a] => ~a\n" o 0)
2091      0)))
2092
2093 (define (formals->locals o)
2094   (pmatch o
2095     ((param-list . ,formals)
2096      (let ((n (length formals)))
2097        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2098     (_ (error "formals->locals: unsupported: " o))))
2099
2100 (define (function->info info)
2101   (lambda (o)
2102     (define (assert-return text)
2103       (let ((return (wrap-as (i386:ret))))
2104         (if (equal? (list-tail text (- (length text) (length return))) return) text
2105             (append text return))))
2106     (let* ((name (.name o))
2107            (formals (.formals o))
2108            (text (formals->text formals))
2109            (locals (formals->locals formals)))
2110       (format (current-error-port) "compiling: ~a\n" name)
2111       (let loop ((statements (.statements o))
2112                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2113         (if (null? statements) (clone info
2114                                       #:function #f
2115                                       #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2116             (let* ((statement (car statements)))
2117               (loop (cdr statements)
2118                     ((ast->info info) (car statements)))))))))
2119
2120 (define (ast-list->info info)
2121   (lambda (elements)
2122     (let loop ((elements elements) (info info))
2123       (if (null? elements) info
2124           (loop (cdr elements) ((ast->info info) (car elements)))))))
2125
2126 (define current-eval
2127   (let ((module (current-module)))
2128     (lambda (e) (eval e module))))
2129
2130 (define (object->list object)
2131   (text->list (map current-eval object)))
2132
2133 (define (dec->xhex o)
2134   (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
2135
2136 (define (write-lambda o)
2137   (newline)
2138   (display "    ")
2139   (if (or (not (pair? o))
2140           (not (eq? (caaddr o) 'list))) (write o)
2141           (list (car o) (cadr o)
2142                 (display (string-append "(lambda (f g ta t d) (list "
2143                                         (string-join (map dec->xhex (cdaddr o)) " ")
2144                                         "))")))))
2145
2146 (define (write-function o)
2147   (stderr "function: ~s\n" (car o))
2148   (newline)
2149   (display "  (")
2150   (write (car o)) (display " ")
2151   (if (not (cdr o)) (display ". #f")
2152       (for-each write-lambda (cdr o)))
2153   (display ")"))
2154
2155 (define (write-info o)
2156   (stderr "object:\n")
2157   (display "(make <info>\n")
2158   (display "  #:types\n  '") (pretty-print (.types o) #:width 80)
2159   (display "  #:constants\n  '") (pretty-print (.constants o) #:width 80)
2160   (display "  #:functions '(") (for-each write-function (.functions o)) (display ")") (newline)
2161   (stderr "globals:\n")
2162   (display "  #:globals\n  '") (pretty-print (.globals o) #:width 80)
2163   (stderr "init:\n")
2164   (display "  #:init\n  '") (pretty-print (.init o) #:width 80)
2165   (display ")\n"))
2166
2167 (define* (c99-input->info #:key (defines '()) (includes '()))
2168   (lambda ()
2169     (let* ((info (make <info> #:types i386:type-alist))
2170            (foo (stderr "parsing: input\n"))
2171            (ast (c99-input->ast #:defines defines #:includes includes))
2172            (foo (stderr "compiling: input\n"))
2173            (info ((ast->info info) ast))
2174            (info (clone info #:text '() #:locals '())))
2175       info)))
2176
2177 (define (write-any x)
2178   (write-char (cond ((char? x) x)
2179                     ((and (number? x) (< (+ x 256) 0))
2180                      (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
2181                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
2182                     ((procedure? x)
2183                      (stderr "write-any: proc: ~a\n" x)
2184                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
2185                      (error "procedure: write-any:" x))
2186                     (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
2187
2188 (define (info->elf info)
2189   (display "dumping elf\n" (current-error-port))
2190   (for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info))))
2191
2192 (define (function:object->text o)
2193   (cons (car o) (and (cdr o) (map current-eval (cdr o)))))
2194
2195 (define (init:object->text o)
2196   (current-eval o))
2197
2198 (define (info:object->text o)
2199   (clone o
2200          #:functions (map function:object->text (.functions o))
2201          #:init (map init:object->text (.init o))))
2202
2203 (define* (c99-ast->info ast)
2204   ((ast->info (make <info> #:types i386:type-alist)) ast))
2205
2206 (define* (c99-input->elf #:key (defines '()) (includes '()))
2207   ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
2208
2209 (define* (c99-input->object #:key (defines '()) (includes '()))
2210   ((compose write-info (c99-input->info #:defines defines #:includes includes))))
2211
2212 (define (object->elf info)
2213   ((compose info->elf info:object->text) info))
2214
2215 (define (infos->object infos)
2216   ((compose write-info merge-infos) infos))
2217
2218 (define (infos->elf infos)
2219   ((compose object->elf merge-infos) infos))
2220
2221 (define (merge-infos infos)
2222   (let loop ((infos infos) (info (make <info>)))
2223     (if (null? infos) info
2224         (loop (cdr infos)
2225               (clone info
2226                      #:types (alist-add (.types info) (.types (car infos)))
2227                      #:constants (alist-add (.constants info) (.constants (car infos)))
2228                      #:functions (alist-add (.functions info) (.functions (car infos)))
2229                      #:globals (alist-add (.globals info) (.globals (car infos)))
2230                      #:init (append (.init info) (.init (car infos))))))))
2231
2232 (define (alist-add a b)
2233   (let* ((b-keys (map car b))
2234          (a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a))
2235          (a-keys (map car a)))
2236     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))