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