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