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 (nyacc lang c99 parser))
  34   (mes-use-module (mes elf-util))
  35   (mes-use-module (mes pmatch))
  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 (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
  50
  51 (define (mescc)
  52   (parse-c99
  53    #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
  54    #:cpp-defs '(
  55                 "__GNUC__=0"
  56                 "__MESC__=1"
  57                 "__NYACC__=1" ;; REMOVEME
  58                 "STDIN=0"
  59                 "STDOUT=1"
  60                 "STDERR=2"
  61                 "O_RDONLY=0"
  62
  63                 "INT_MIN=-2147483648"
  64                 "INT_MAX=2147483647"
  65
  66                 "VERSION=\"0.4\""
  67                 "PREFIX=\"\""
  68                 )
  69    #:xdef? gnuc-xdef?
  70    #:mode 'code
  71    ))
  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         ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
 558          (let* ((index (cstring->number index))
 559                 (type (ident->type info array))
 560                 (size (type->size info type)))
 561            (clone info #:text
 562                   (append text
 563                         ((ident->base info) array)
 564                         (list (lambda (f g ta t d)
 565                                 (append
 566                                  (i386:value->accu (* size index))
 567                                  (if (eq? size 1)
 568                                      (i386:byte-base-mem->accu)
 569                                      (i386:base-mem->accu)))))))))
 570
 571         ;; c+p expr->arg
 572         ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
 573          (let* ((type (ident->type info array))
 574                 (size (type->size info type)))
 575            (clone info #:text (append text
 576                                       ((ident->base info) index)
 577                                       (list (lambda (f g ta t d)
 578                                               (append
 579                                                (i386:base->accu)
 580                                                (if (< size 4) '()
 581                                                    (append  ;; FIXME
 582                                                      (i386:accu+accu)
 583                                                      (if (= size 12) (i386:accu+base)
 584                                                          '()))))))
 585                                       ((ident->base info) array)
 586                                       (list (lambda (f g ta t d)
 587                                               (if (eq? size 1)
 588                                                   (i386:byte-base-mem->accu)
 589                                                   (i386:base-mem->accu))))))))
 590
 591         ;; f.field
 592         ((d-sel (ident ,field) (p-expr (ident ,array)))
 593          (let* ((type (ident->type info array))
 594                 (fields (type->description info type))
 595                 (field-size 4) ;; FIXME:4, not fixed
 596                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 597                 (text (.text info)))
 598            (clone info #:text
 599                   (append text
 600                           ((ident->accu info) array)
 601                           (list (lambda (f g ta t d)
 602                                   (i386:mem+n->accu offset)))))))
 603
 604         ;; g_cells[10].type
 605         ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
 606          (let* ((type (ident->type info array))
 607                 (fields (or (type->description info type) '()))
 608                 (size (type->size info type))
 609                 (count (length fields))
 610                 (field-size 4) ;; FIXME:4, not fixed
 611                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 612                 (index (cstring->number index))
 613                 (text (.text info)))
 614            (clone info #:text
 615                   (append text
 616                           (list (lambda (f g ta t d)
 617                                   (append
 618                                    (i386:value->base index)
 619                                    (i386:base->accu)
 620                                    (if (> count 1) (i386:accu+accu) '())
 621                                    (if (= count 3) (i386:accu+base) '())
 622                                    (i386:accu-shl 2))))
 623                           ((ident->base info) array)
 624                           (list (lambda (f g ta t d)
 625                                   (i386:base-mem+n->accu offset)))))))
 626
 627         ;; g_cells[x].type
 628         ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
 629          (let* ((type (ident->type info array))
 630                 (fields (or (type->description info type) '()))
 631                 (size (type->size info type))
 632                 (count (length fields))
 633                 (field-size 4) ;; FIXME:4, not fixed
 634                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 635                       (text (.text info)))
 636                  (clone info #:text
 637                         (append text
 638                                 ((ident->base info) index)
 639                                 (list (lambda (f g ta t d)
 640                                         (append
 641                                          (i386:base->accu)
 642                                          (if (> count 1) (i386:accu+accu) '())
 643                                          (if (= count 3) (i386:accu+base) '())
 644                                          (i386:accu-shl 2))))
 645                                 ((ident->base info) array)
 646                                 (list (lambda (f g ta t d)
 647                                         (i386:base-mem+n->accu offset)))))))
 648
 649         ;; g_functions[g_cells[fn].cdr].arity
 650         ;; INDEX0: g_cells[fn].cdr
 651
 652         ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
 653         ;;((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)))))
 654         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
 655          (let* ((empty (clone info #:text '()))
 656                 (index ((expr->accu empty) index))
 657                 (type (ident->type info array))
 658                 (fields (or (type->description info type) '()))
 659                 (size (type->size info type))
 660                 (count (length fields))
 661                 (field-size 4) ;; FIXME:4, not fixed
 662                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
 663                           barf
 664                           '()))
 665                 (offset (* field-size (1- (length rest))))
 666                 (text (.text info)))
 667            (clone info #:text
 668                   (append text
 669                           (.text index)
 670                           (list (lambda (f g ta t d)
 671                                   (append
 672                                    (i386:accu->base)
 673                                    (if (> count 1) (i386:accu+accu) '())
 674                                    (if (= count 3) (i386:accu+base) '())
 675                                    (i386:accu-shl 2))))
 676                           ((ident->base info) array)
 677                           (list (lambda (f g ta t d)
 678                                   (i386:base-mem+n->accu offset)))))))
 679
 680         ;;; FIXME: FROM INFO ...only zero?!
 681         ((p-expr (fixed ,value))
 682          (let ((value (cstring->number value)))
 683           (clone info #:text
 684                  (append text
 685                          (list (lambda (f g ta t d)
 686                                  (i386:value->accu value)))))))
 687
 688         ((p-expr (char ,char))
 689          (let ((char (char->integer (car (string->list char)))))
 690           (clone info #:text
 691                  (append text
 692                          (list (lambda (f g ta t d)
 693                                  (i386:value->accu char)))))))
 694
 695         ((p-expr (ident ,name))
 696          (clone info #:text
 697                 (append text
 698                         ((ident->accu info) name))))
 699
 700         ((de-ref (p-expr (ident ,name)))
 701          (let* ((type (ident->type info name))
 702                 (size (and type (type->size info type))))
 703           (clone info #:text
 704                  (append text
 705                          ((ident->accu info) name)
 706                          (list (lambda (f g ta t d)
 707                                  (if (= size 1)
 708                                      (i386:byte-mem->accu)
 709                                      (i386:mem->accu))))))))
 710
 711         ;; GRR --> info again??!?
 712         ((fctn-call . ,call)
 713          ((ast->info info) `(expr-stmt ,o)))
 714
 715         ((cond-expr . ,cond-expr)
 716          ((ast->info info) `(expr-stmt ,o)))
 717
 718         ;; FIXME
 719         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
 720         ((post-inc (p-expr (ident ,name)))
 721          (clone info #:text
 722                 (append text
 723                         ((ident->accu info) name)
 724                         ((ident-add info) name 1))))
 725
 726         ;; GRR --> info again??!?
 727         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
 728         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
 729         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
 730         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
 731
 732         ((add (p-expr (ident ,name)) ,b)
 733          (let* ((empty (clone info #:text '()))
 734                 (base ((expr->base empty) b)))
 735            (clone info #:text
 736                   (append text
 737                           (.text base)
 738                           ((ident->accu info) name)
 739                           (list (lambda (f g ta t d)
 740                                   (i386:accu+base)))))))
 741
 742         ((add ,a ,b)
 743          (let* ((empty (clone info #:text '()))
 744                 (accu ((expr->accu empty) a))
 745                 (base ((expr->base empty) b)))
 746            (clone info #:text
 747                   (append text
 748                           (.text accu)
 749                           (.text base)
 750                           (list (lambda (f g ta t d)
 751                                   (i386:accu+base)))))))
 752
 753         ((sub ,a ,b)
 754          (let* ((empty (clone info #:text '()))
 755                 (accu ((expr->accu empty) a))
 756                 (base ((expr->base empty) b)))
 757            (clone info #:text
 758                   (append text
 759                           (.text accu)
 760                           (.text base)
 761                           (list (lambda (f g ta t d)
 762                                   (i386:accu-base)))))))
 763
 764         ((bitwise-or ,a ,b)
 765          (let* ((empty (clone info #:text '()))
 766                 (accu ((expr->accu empty) a))
 767                 (base ((expr->base empty) b)))
 768            (clone info #:text
 769                   (append text
 770                           (.text accu)
 771                           (.text base)
 772                           (list (lambda (f g ta t d)
 773                                   (i386:accu-or-base)))))))
 774
 775         ((lshift ,a ,b)
 776          (let* ((empty (clone info #:text '()))
 777                 (accu ((expr->accu empty) a))
 778                 (base ((expr->base empty) b)))
 779            (clone info #:text
 780                   (append text
 781                           (.text accu)
 782                           (.text base)
 783                           (list (lambda (f g ta t d)
 784                                   (i386:accu<<base)))))))
 785
 786         ((div ,a ,b)
 787          (let* ((empty (clone info #:text '()))
 788                 (accu ((expr->accu empty) a))
 789                 (base ((expr->base empty) b)))
 790            (clone info #:text
 791                   (append text
 792                           (.text accu)
 793                           (.text base)
 794                           (list (lambda (f g ta t d)
 795                                   (i386:accu/base)))))))
 796
 797         ((mod ,a ,b)
 798          (let* ((empty (clone info #:text '()))
 799                 (accu ((expr->accu empty) a))
 800                 (base ((expr->base empty) b)))
 801            (clone info #:text
 802                   (append text ;;FIXME:empty
 803                           (.text accu)
 804                           (.text base)
 805                           (list (lambda (f g ta t d)
 806                                   (i386:accu%base)))))))
 807
 808         ((mul ,a ,b)
 809          (let* ((empty (clone info #:text '()))
 810                 (accu ((expr->accu empty) a))
 811                 (base ((expr->base empty) b)))
 812            (clone info #:text
 813                   (append text
 814                           (.text accu)
 815                           (.text base)
 816                           (list (lambda (f g ta t d)
 817                                   (i386:accu*base)))))))
 818
 819         ;; FIXME: c/p ast->info
 820         ((eq ,a ,b)
 821          (let* ((base ((expr->base info) a))
 822                 (empty (clone base #:text '()))
 823                 (accu ((expr->accu empty) b)))
 824            (clone info #:text
 825                   (append (.text base)
 826                           (list (lambda (f g ta t d)
 827                                   (i386:push-base)))
 828                           (.text accu)
 829                           (list (lambda (f g ta t d)
 830                                   (i386:pop-base)))
 831                           (list (lambda (f g ta t d)
 832                                   (i386:sub-base)))))))
 833
 834         ;; FIXME: c/p ast->info
 835         ((lt ,a ,b)
 836          (let* ((base ((expr->base info) a))
 837                 (empty (clone base #:text '()))
 838                 (accu ((expr->accu empty) b)))
 839            (clone info #:text
 840                   (append (.text base)
 841                           (.text accu)
 842                           (list (lambda (f g ta t d)
 843                                   (i386:base-sub)))))))
 844
 845         ;; FIXME: ...c/p ast->info
 846         ((neg (p-expr (ident ,name)))
 847          (clone info #:text (append text
 848                                     ((ident->base info) name)
 849                                     (list (lambda (f g ta t d)
 850                                             (i386:value->accu 0)))
 851                                     (list (lambda (f g ta t d)
 852                                             (i386:base-sub))))))
 853
 854         ;;((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"))))))
 855         ((cast ,cast ,o)
 856          ((expr->accu info) o))
 857
 858         ((assn-expr (p-expr (ident ,name)) ,op ,expr)
 859          (let ((info ((ast->info info) o)))
 860            (clone info #:text (append (.text info)
 861                                       ((ident->accu info) name)))))
 862
 863         (_
 864          (format (current-error-port) "SKIP: expr->accu=~s\n" o)
 865          barf
 866          info)))))
 867
 868 (define (expr->base info)
 869   (lambda (o)
 870     (let ((info ((expr->accu info) o)))
 871       (clone info
 872              #:text (append
 873                      (list (lambda (f g ta t d)
 874                              (i386:push-accu)))
 875                      (.text info)
 876                      (list (lambda (f g ta t d)
 877                              (append
 878                               (i386:accu->base)
 879                               (i386:pop-accu)))))))))
 880
 881 (define (expr->accu* info)
 882   (lambda (o)
 883     (pmatch o
 884       ;;(stderr "expr->accu* o=~s\n" o)
 885       ;; g_cells[10].type
 886       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
 887        (let* ((type (ident->type info array))
 888               (fields (or (type->description info type) '()))
 889               (size (type->size info type))
 890               (count (length fields))
 891               (field-size 4) ;; FIXME:4, not fixed
 892               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 893               (index (cstring->number index))
 894               (text (.text info)))
 895          (clone info #:text
 896                 (append text
 897                         (list (lambda (f g ta t d)
 898                                 (append
 899                                  (i386:value->base index)
 900                                  (i386:base->accu)
 901                                  (if (> count 1) (i386:accu+accu) '())
 902                                  (if (= count 3) (i386:accu+base) '())
 903                                  (i386:accu-shl 2))))
 904                         ;; de-ref: g_cells, non: arena
 905                         ;;((ident->base info) array)
 906                         ((ident->base info) array)
 907                         (list (lambda (f g ta t d)
 908                                 (append
 909                                  (i386:accu+base)
 910                                  (i386:accu+value offset))))))))
 911
 912       ;; g_cells[x].type
 913       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
 914        (let* ((type (ident->type info array))
 915               (fields (or (type->description info type) '()))
 916               (size (type->size info type))
 917               (count (length fields))
 918               (field-size 4) ;; FIXME:4, not fixed
 919               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 920               (text (.text info)))
 921          (clone info #:text
 922                 (append text
 923                         ((ident->base info) index)
 924                         (list (lambda (f g ta t d)
 925                                 (append
 926                                  (i386:base->accu)
 927                                  (if (> count 1) (i386:accu+accu) '())
 928                                  (if (= count 3) (i386:accu+base) '())
 929                                  (i386:accu-shl 2))))
 930                         ;; de-ref: g_cells, non: arena
 931                         ;;((ident->base info) array)
 932                         ((ident->base info) array)
 933                         (list (lambda (f g ta t d)
 934                                 (append
 935                                  (i386:accu+base)
 936                                  (i386:accu+value offset))))))))
 937
 938       ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
 939       ((d-sel (ident ,field) (p-expr (ident ,name)))
 940        (let* ((type (ident->type info name))
 941               (fields (or (type->description info type) '()))
 942               (field-size 4) ;; FIXME
 943               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 944               (text (.text info)))
 945          (clone info #:text
 946                 (append text
 947                         ((ident->accu info) name)
 948                         (list (lambda (f g ta t d)
 949                                 (i386:accu+value offset)))))))
 950
 951       (_
 952        (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
 953        barf
 954        info)
 955       )))
 956
 957 (define (ident->constant name value)
 958   (cons name value))
 959
 960 (define (make-type name type size description)
 961   (cons name (list type size description)))
 962
 963 (define (enum->type name fields)
 964   (make-type name 'enum 4 fields))
 965
 966 (define (struct->type name fields)
 967   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
 968
 969 (define (decl->type o)
 970   (pmatch o
 971     ((fixed-type ,type) type)
 972     ((struct-ref (ident ,name)) (list "struct" name))
 973     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
 974      (list "struct" name)) ;; FIXME
 975     ((typename ,name) name)
 976     (_
 977      (stderr "SKIP: decl type=~s\n" o)
 978      barf
 979      o)))
 980
 981 (define (expr->global o)
 982   (pmatch o
 983     ((p-expr (string ,string)) (string->global string))
 984     (_ #f)))
 985
 986 (define (initzer->global o)
 987   (pmatch o
 988     ((initzer ,initzer) (expr->global initzer))
 989     (_ #f)))
 990
 991 (define (byte->hex o)
 992   (string->number (string-drop o 2) 16))
 993
 994 (define (asm->hex o)
 995   (let ((prefix ".byte "))
 996     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
 997         (let ((s (string-drop o (string-length prefix))))
 998           (map byte->hex (string-split s #\space))))))
 999
1000 (define (case->jump-info info)
1001   (define (jump n)
1002     (list (lambda (f g ta t d) (i386:Xjump n))))
1003   (define (jump-nz n)
1004     (list (lambda (f g ta t d) (i386:Xjump-nz n))))
1005   (define (statement->info info body-length)
1006     (lambda (o)
1007       (pmatch o
1008         ((break) (clone info #:text (append (.text info) (jump body-length)
1009 )))
1010         (_
1011          ((ast->info info) o)))))
1012   (lambda (o)
1013     (pmatch o
1014       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
1015        (lambda (body-length)
1016
1017          (define (test->text value clause-length)
1018            (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1019                    (jump-nz clause-length)))
1020          (let* ((value (assoc-ref (.constants info) constant))
1021                 (test-info
1022                  (clone info #:text (append (.text info) (test->text value 0))))
1023                 (text-length (length (.text test-info)))
1024                 (clause-info (let loop ((elements elements) (info test-info))
1025                                (if (null? elements) info
1026                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1027                 (clause-text (list-tail (.text clause-info) text-length))
1028                 (clause-length (length (text->list clause-text))))
1029            (clone info #:text (append
1030                                (.text info)
1031                                (test->text value clause-length)
1032                                clause-text)
1033                   #:globals (.globals clause-info)))))
1034
1035       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
1036        (lambda (body-length)
1037
1038          (define (test->text value clause-length)
1039            (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1040                    (jump-nz clause-length)))
1041          (let* ((value (cstring->number value))
1042                 (test-info
1043                  (clone info #:text (append (.text info) (test->text value 0))))
1044                 (text-length (length (.text test-info)))
1045                 (clause-info (let loop ((elements elements) (info test-info))
1046                                (if (null? elements) info
1047                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1048                 (clause-text (list-tail (.text clause-info) text-length))
1049                 (clause-length (length (text->list clause-text))))
1050            (clone info #:text (append
1051                                (.text info)
1052                                (test->text value clause-length)
1053                                clause-text)
1054                   #:globals (.globals clause-info)))))
1055
1056       ((case (neg (p-expr (fixed ,value))) ,statement)
1057        ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
1058
1059       ((default (compd-stmt (block-item-list . ,elements)))
1060        (lambda (body-length)
1061          (let ((text-length (length (.text info))))
1062           (let loop ((elements elements) (info info))
1063             (if (null? elements) info
1064                 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
1065
1066       ((case (p-expr (ident ,constant)) ,statement)
1067        ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
1068
1069       ((case (p-expr (fixed ,value)) ,statement)
1070        ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
1071
1072       ((default ,statement)
1073        ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
1074
1075       (_ (stderr "no case match: ~a\n" o) barf)
1076       )))
1077
1078 (define (test->jump->info info)
1079   (define (jump type . test)
1080     (lambda (o)
1081       (let* ((text (.text info))
1082              (info (clone info #:text '()))
1083              (info ((ast->info info) o))
1084              (jump-text (lambda (body-length)
1085                           (list (lambda (f g ta t d) (type body-length))))))
1086        (lambda (body-length)
1087          (clone info #:text
1088                 (append text
1089                         (.text info)
1090                         (if (null? test) '() (car test))
1091                         (jump-text body-length)))))))
1092   (lambda (o)
1093     (pmatch o
1094       ;; unsigned
1095       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1096       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
1097       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1098       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1099
1100       ((le ,a ,b) ((jump i386:Xjump-g) o))
1101       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1102       ((ge ,a ,b) ((jump i386:Xjump-g) o))
1103       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1104
1105       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1106       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1107       ((not _) ((jump i386:Xjump-z) o))
1108       ((and ,a ,b)
1109        (let* ((text (.text info))
1110               (info (clone info #:text '()))
1111
1112               (a-jump ((test->jump->info info) a))
1113               (a-text (.text (a-jump 0)))
1114               (a-length (length (text->list a-text)))
1115
1116               (b-jump ((test->jump->info info) b))
1117               (b-text (.text (b-jump 0)))
1118               (b-length (length (text->list b-text))))
1119
1120          (lambda (body-length)
1121            (clone info #:text
1122                   (append text
1123                           (.text (a-jump (+ b-length body-length)))
1124                           (.text (b-jump body-length)))))))
1125       ((or ,a ,b)
1126        (let* ((text (.text info))
1127               (info (clone info #:text '()))
1128
1129               (a-jump ((test->jump->info info) a))
1130               (a-text (.text (a-jump 0)))
1131               (a-length (length (text->list a-text)))
1132
1133               (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1134               (jump-length (length (text->list jump-text)))
1135
1136               (b-jump ((test->jump->info info) b))
1137               (b-text (.text (b-jump 0)))
1138               (b-length (length (text->list b-text)))
1139
1140               (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
1141
1142          (lambda (body-length)
1143            (clone info #:text
1144                   (append text
1145                           (.text (a-jump jump-length))
1146                           jump-text
1147                           (.text (b-jump body-length)))))))
1148
1149       ((array-ref . _) ((jump i386:jump-byte-z
1150                               (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1151
1152       ((de-ref _) ((jump i386:jump-byte-z
1153                          (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1154
1155       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1156        ((jump i386:Xjump-z
1157               (append
1158                ((ident->accu info) name)
1159                (list (lambda (f g ta t d) (i386:accu-zero?))))) o))
1160
1161       (_ ((jump i386:Xjump-z (list (lambda (f g ta t d) (i386:accu-zero?)))) o)))))
1162
1163 (define (cstring->number s)
1164   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1165         ((string-prefix? "0" s) (string->number s 8))
1166         (else (string->number s))))
1167
1168 (define (struct-field o)
1169   (pmatch o
1170     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1171                 (comp-declr-list (comp-declr (ident ,name))))
1172      (cons type name))
1173     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1174      (cons type name))
1175     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1176      (cons type name))
1177     ((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)))))))))
1178      (cons type name)) ;; FIXME function / int
1179     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1180      (cons type name)) ;; FIXME: ptr/char
1181     (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1182
1183 (define (ast->type o)
1184   (pmatch o
1185     ((fixed-type ,type)
1186      type)
1187     ((struct-ref (ident ,type))
1188      (list "struct" type))
1189     (_ (stderr "SKIP: type=~s\n" o)
1190        "int")))
1191
1192 (define i386:type-alist
1193   '(("char" . (builtin 1 #f))
1194     ("int" . (builtin 4 #f))))
1195
1196 (define (type->size info o)
1197   ;;(stderr  "types=~s\n" (.types info))
1198   ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
1199   (pmatch o
1200     ((decl-spec-list (type-spec (fixed-type ,type)))
1201      (type->size info type))
1202     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1203      (type->size info type))
1204     (_ (let ((type (assoc-ref (.types info) o)))
1205          (if type (cadr type)
1206              (begin
1207                (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1208                barf
1209                4))))))
1210
1211 (define (ident->decl info o)
1212   ;; (stderr "ident->decl o=~s\n" o)
1213   ;; (stderr "  types=~s\n" (.types info))
1214   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
1215   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
1216   (or (assoc-ref (.locals info) o)
1217       (assoc-ref (.globals info) o)
1218       (begin
1219         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1220         (assoc-ref (.functions info) o))))
1221
1222 (define (ident->type info o)
1223   (and=> (ident->decl info o) car))
1224
1225 (define (ident->pointer info o)
1226   (let ((local (assoc-ref (.locals info) o)))
1227     (if local (local:pointer local)
1228         (or (and=> (ident->decl info o) global:pointer) 0))))
1229
1230 (define (type->description info o)
1231   ;; (stderr  "type->description =~s\n" o)
1232   ;; (stderr  "types=~s\n" (.types info))
1233   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
1234   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
1235   (pmatch o
1236     ((decl-spec-list (type-spec (fixed-type ,type)))
1237      (type->description info type))
1238     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1239      (type->description info type))
1240     (_ (caddr (assoc-ref (.types info) o)))))
1241
1242 (define (local? o) ;; formals < 0, locals > 0
1243   (positive? (local:id o)))
1244
1245 (define (ast->info info)
1246   (lambda (o)
1247     (let ((globals (.globals info))
1248           (locals (.locals info))
1249           (constants (.constants info))
1250           (text (.text info)))
1251       (define (add-local locals name type pointer)
1252         (let* ((id (1+ (length (filter local? (map cdr locals)))))
1253                (locals (cons (make-local name type pointer id) locals)))
1254           locals))
1255
1256       ;; (stderr "\n ast->info=~s\n" o)
1257       ;; (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)))
1258       ;; (stderr "  text=~a\n" text)
1259       ;; (stderr "   info=~a\n" info)
1260       ;; (stderr "   globals=~a\n" globals)
1261       (pmatch o
1262         (((trans-unit . _) . _)
1263          ((ast-list->info info)  o))
1264         ((trans-unit . ,elements)
1265          ((ast-list->info info) elements))
1266         ((fctn-defn . _) ((function->info info) o))
1267         ((comment . _) info)
1268         ((cpp-stmt (define (name ,name) (repl ,value)))
1269          info)
1270
1271         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1272          info)
1273
1274         ;; FIXME: expr-stmt wrapper?
1275         (trans-unit info)
1276         ((expr-stmt) info)
1277         ((assn-expr . ,assn-expr)
1278          ((ast->info info) `(expr-stmt ,o)))
1279
1280         ((d-sel . ,d-sel)
1281          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1282            expr))
1283
1284         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1285
1286         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1287          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1288                                    (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1289              (let* ((globals (append globals (filter-map expr->global expr-list)))
1290                     (info (clone info #:globals globals))
1291                     (text-length (length text))
1292                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
1293                                  (if (null? expressions) info
1294                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1295                     (text (.text args-info))
1296                     (n (length expr-list)))
1297                (if (and (not (assoc-ref locals name))
1298                         (assoc-ref (.functions info) name))
1299                 (clone args-info #:text
1300                        (append text
1301                                (list (lambda (f g ta t d)
1302                                        (i386:call f g ta t d (+ t (function-offset name f)) n))))
1303                        #:globals globals)
1304                 (let* ((empty (clone info #:text '()))
1305                        (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1306                   (clone args-info #:text
1307                          (append text
1308                                  (.text accu)
1309                                  (list (lambda (f g ta t d)
1310                                          (i386:call-accu f g ta t d n))))
1311                          #:globals globals))))))
1312
1313         ;;((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))))
1314         ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1315          (let* ((globals (append globals (filter-map expr->global expr-list)))
1316                 (info (clone info #:globals globals))
1317                 (text-length (length text))
1318                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1319                              (if (null? expressions) info
1320                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1321                 (text (.text args-info))
1322                 (n (length expr-list))
1323                 (empty (clone info #:text '()))
1324                 (accu ((expr->accu empty) function)))
1325            (clone info #:text
1326                   (append text
1327                           (.text accu)
1328                           (list (lambda (f g ta t d)
1329                                   (i386:call-accu f g ta t d n))))
1330                   #:globals globals)))
1331
1332         ((if ,test ,body)
1333          (let* ((text-length (length text))
1334
1335                 (test-jump->info ((test->jump->info info) test))
1336                 (test+jump-info (test-jump->info 0))
1337                 (test-length (length (.text test+jump-info)))
1338
1339                 (body-info ((ast->info test+jump-info) body))
1340                 (text-body-info (.text body-info))
1341                 (body-text (list-tail text-body-info test-length))
1342                 (body-length (length (text->list body-text)))
1343
1344                 (text+test-text (.text (test-jump->info body-length)))
1345                 (test-text (list-tail text+test-text text-length)))
1346
1347            (clone info #:text
1348                   (append text
1349                           test-text
1350                           body-text)
1351                   #:globals (.globals body-info))))
1352
1353         ((if ,test ,then ,else)
1354          (let* ((text-length (length text))
1355
1356                 (test-jump->info ((test->jump->info info) test))
1357                 (test+jump-info (test-jump->info 0))
1358                 (test-length (length (.text test+jump-info)))
1359
1360                 (then-info ((ast->info test+jump-info) then))
1361                 (text-then-info (.text then-info))
1362                 (then-text (list-tail text-then-info test-length))
1363                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1364                 (then-jump-length (length (text->list then-jump-text)))
1365                 (then-length (+ (length (text->list then-text)) then-jump-length))
1366
1367                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1368                 (else-info ((ast->info then+jump-info) else))
1369                 (text-else-info (.text else-info))
1370                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1371                 (else-length (length (text->list else-text)))
1372
1373                 (text+test-text (.text (test-jump->info then-length)))
1374                 (test-text (list-tail text+test-text text-length))
1375                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1376
1377            (clone info #:text
1378                   (append text
1379                           test-text
1380                           then-text
1381                           then-jump-text
1382                           else-text)
1383                   #:globals (append (.globals then-info)
1384                                     (list-tail (.globals else-info) (length globals))))))
1385
1386         ((expr-stmt (cond-expr ,test ,then ,else))
1387          (let* ((text-length (length text))
1388
1389                 (test-jump->info ((test->jump->info info) test))
1390                 (test+jump-info (test-jump->info 0))
1391                 (test-length (length (.text test+jump-info)))
1392
1393                 (then-info ((ast->info test+jump-info) then))
1394                 (text-then-info (.text then-info))
1395                 (then-text (list-tail text-then-info test-length))
1396                 (then-length (length (text->list then-text)))
1397
1398                 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1399                 (jump-length (length (text->list jump-text)))
1400
1401                 (test+then+jump-info
1402                  (clone then-info
1403                         #:text (append (.text then-info) jump-text)))
1404
1405                 (else-info ((ast->info test+then+jump-info) else))
1406                 (text-else-info (.text else-info))
1407                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1408                 (else-length (length (text->list else-text)))
1409
1410                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1411                 (test-text (list-tail text+test-text text-length))
1412                 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1413
1414            (clone info #:text
1415                   (append text
1416                           test-text
1417                           then-text
1418                           jump-text
1419                           else-text)
1420                   #:globals (.globals else-info))))
1421
1422         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1423          (let* ((expr ((expr->accu info) expr))
1424                 (empty (clone info #:text '()))
1425                 (case-infos (map (case->jump-info empty) cases))
1426                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1427                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1428                               (if (null? cases) info
1429                                   (let ((c-j ((case->jump-info info) (car cases))))
1430                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1431            cases-info))
1432
1433         ((for ,init ,test ,step ,body)
1434          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1435
1436                 (info ((ast->info info) init))
1437
1438                 (init-text (.text info))
1439                 (init-locals (.locals info))
1440                 (info (clone info #:text '()))
1441
1442                 (body-info ((ast->info info) body))
1443                 (body-text (.text body-info))
1444                 (body-length (length (text->list body-text)))
1445
1446                 (step-info ((ast->info info) `(expr-stmt ,step)))
1447                 (step-text (.text step-info))
1448                 (step-length (length (text->list step-text)))
1449
1450                 (test-jump->info ((test->jump->info info) test))
1451                 (test+jump-info (test-jump->info 0))
1452                 (test-length (length (text->list (.text test+jump-info))))
1453
1454                 (skip-body-text (list (lambda (f g ta t d)
1455                                         (i386:Xjump (+ body-length step-length)))))
1456
1457                 (jump-text (list (lambda (f g ta t d)
1458                                    (i386:Xjump (- (+ body-length step-length test-length))))))
1459                 (jump-length (length (text->list jump-text)))
1460
1461                 (test-text (.text (test-jump->info jump-length))))
1462
1463            (clone info #:text
1464                   (append text
1465                           init-text
1466                           skip-body-text
1467                           body-text
1468                           step-text
1469                           test-text
1470                           jump-text)
1471                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1472                   #:locals locals)))
1473
1474         ;; FIXME: support break statement (see switch/case)
1475         ((while ,test ,body)
1476          (let* ((skip-info (lambda (body-length)
1477                              (clone info #:text (append text
1478                                                         (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
1479                 (text (.text (skip-info 0)))
1480                 (text-length (length text))
1481
1482                 (body-info (lambda (body-length)
1483                              ((ast->info (skip-info body-length)) body)))
1484                 (body-text (list-tail (.text (body-info 0)) text-length))
1485                 (body-length (length (text->list body-text)))
1486
1487                 (body-info (body-info body-length))
1488
1489                 (empty (clone info #:text '()))
1490                 (test-jump->info ((test->jump->info empty) test))
1491                 (test+jump-info (test-jump->info 0))
1492                 (test-length (length (text->list (.text test+jump-info))))
1493
1494                 (jump-text (list (lambda (f g ta t d)
1495                                    (i386:Xjump (- (+ body-length test-length))))))
1496                 (jump-length (length (text->list jump-text)))
1497
1498                 (test-text (.text (test-jump->info jump-length))))
1499            (clone info #:text
1500                   (append
1501                    (.text body-info)
1502                    test-text
1503                    jump-text)
1504                   #:globals (.globals body-info))))
1505
1506         ((do-while ,body ,test)
1507          (let* ((text-length (length text))
1508
1509                 (body-info ((ast->info info) body))
1510                 (body-text (list-tail (.text body-info) text-length))
1511                 (body-length (length (text->list body-text)))
1512
1513                 (empty (clone info #:text '()))
1514                 (test-jump->info ((test->jump->info empty) test))
1515                 (test+jump-info (test-jump->info 0))
1516                 (test-length (length (text->list (.text test+jump-info))))
1517
1518                 (jump-text (list (lambda (f g ta t d)
1519                                    (i386:Xjump (- (+ body-length test-length))))))
1520                 (jump-length (length (text->list jump-text)))
1521
1522                 (test-text (.text (test-jump->info jump-length))))
1523            (clone info #:text
1524                   (append
1525                    (.text body-info)
1526                    test-text
1527                    jump-text)
1528                   #:globals (.globals body-info))))
1529
1530         ((labeled-stmt (ident ,label) ,statement)
1531          (let ((info (clone info #:text (append text (list label)))))
1532            ((ast->info info) statement)))
1533
1534         ((goto (ident ,label))
1535          (let* ((jump (lambda (n) (i386:XXjump n)))
1536                 (offset (+ (length (jump 0)) (length (text->list text)))))
1537            (clone info #:text
1538                   (append text
1539                           (list (lambda (f g ta t d)
1540                                   (jump (- (label-offset (.function info) label f) offset))))))))
1541
1542         ;;; FIXME: only zero?!
1543         ((p-expr (ident ,name))
1544          (clone info #:text
1545                 (append text
1546                         ((ident->accu info) name)
1547                         (list (lambda (f g ta t d)
1548                                 (append
1549                                  (i386:accu-zero?)))))))
1550
1551         ((p-expr (fixed ,value))
1552          (let ((value (cstring->number value)))
1553           (clone info #:text
1554                  (append text
1555                          (list (lambda (f g ta t d)
1556                                  (append
1557                                   (i386:value->accu value)
1558                                   (i386:accu-zero?))))))))
1559
1560         ((de-ref (p-expr (ident ,name)))
1561          (clone info #:text
1562                 (append text
1563                         ((ident->accu info) name)
1564                         (list (lambda (f g ta t d)
1565                                 (append
1566                                  (i386:byte-mem->accu)))))))
1567
1568         ((fctn-call . ,call)
1569          (let ((info ((ast->info info) `(expr-stmt ,o))))
1570            (clone info #:text
1571                   (append (.text info)
1572                           (list (lambda (f g ta t d)
1573                                   (i386:accu-zero?)))))))
1574
1575         ;; FIXME
1576         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1577         ((post-inc (p-expr (ident ,name)))
1578          (clone info #:text
1579                 (append text
1580                         ((ident->accu info) name)
1581                         ((ident-add info) name 1)
1582                         (list (lambda (f g ta t d)
1583                                 (append
1584                                  (i386:accu-zero?)))))))
1585         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1586         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1587         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1588         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1589
1590         ;; i++
1591         ((expr-stmt (post-inc (p-expr (ident ,name))))
1592          (clone info #:text (append text ((ident-add info) name 1))))
1593
1594         ;; ++i
1595         ((expr-stmt (pre-inc (p-expr (ident ,name))))
1596          (or (assoc-ref locals name) barf)
1597          (clone info #:text
1598                 (append text
1599                         ((ident-add info) name 1)
1600                         ((ident->accu info) name)
1601                         (list (lambda (f g ta t d)
1602                                 (append
1603                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1604                                  (i386:accu-zero?)))))))
1605
1606         ;; i--
1607         ((expr-stmt (post-dec (p-expr (ident ,name))))
1608          (or (assoc-ref locals name) barf)
1609          (clone info #:text
1610                 (append text
1611                         ((ident->accu info) name)
1612                         ((ident-add info) name -1)
1613                         (list (lambda (f g ta t d)
1614                                 (append
1615                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1616                                  (i386:accu-zero?)))))))
1617
1618         ;; --i
1619         ((expr-stmt (pre-dec (p-expr (ident ,name))))
1620          (or (assoc-ref locals name) barf)
1621          (clone info #:text
1622                 (append text
1623                         ((ident-add info) name -1)
1624                         ((ident->accu info) name)
1625                         (list (lambda (f g ta t d)
1626                                 (append
1627                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1628                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1629                                  (i386:accu-zero?)))))))
1630
1631         ((not ,expr)
1632          (let* ((test-info ((ast->info info) expr)))
1633            (clone info #:text
1634                   (append (.text test-info)
1635                           (list (lambda (f g ta t d)
1636                                   (append
1637                                    (i386:accu-not)
1638                                    (i386:accu-zero?)))))
1639                   #:globals (.globals test-info))))
1640
1641         ((eq ,a ,b)
1642          (let* ((base ((expr->base info) a))
1643                 (empty (clone base #:text '()))
1644                 (accu ((expr->accu empty) b)))
1645            (clone info #:text
1646                   (append text
1647                           (.text base)
1648                           (list (lambda (f g ta t d)
1649                                   (i386:push-base)))
1650                           (.text accu)
1651                           (list (lambda (f g ta t d)
1652                                   (i386:pop-base)))
1653                           (list (lambda (f g ta t d)
1654                                   (i386:sub-base)))))))
1655
1656         ((ge ,a ,b)
1657          (let* ((base ((expr->base info) a))
1658                 (empty (clone base #:text '()))
1659                 (accu ((expr->accu empty) b)))
1660            (clone info #:text
1661                   (append text
1662                           (.text base)
1663                           (list (lambda (f g ta t d)
1664                                   (i386:push-base)))
1665                           (.text accu)
1666                           (list (lambda (f g ta t d)
1667                                   (i386:pop-base)))
1668                           (list (lambda (f g ta t d)
1669                                   (i386:sub-base)))))))
1670
1671         ((gt ,a ,b)
1672          (let* ((base ((expr->base info) a))
1673                 (empty (clone base #:text '()))
1674                 (accu ((expr->accu empty) b)))
1675            (clone info #:text
1676                   (append text
1677                           (.text base)
1678                           (list (lambda (f g ta t d)
1679                                   (i386:push-base)))
1680                           (.text accu)
1681                           (list (lambda (f g ta t d)
1682                                   (i386:pop-base)))
1683                           (list (lambda (f g ta t d)
1684                                   (i386:sub-base)))))))
1685
1686         ((ne ,a ,b)
1687          (let* ((base ((expr->base info) a))
1688                 (empty (clone base #:text '()))
1689                 (accu ((expr->accu empty) b)))
1690            (clone info #:text
1691                   (append text
1692                           (.text base)
1693                           (list (lambda (f g ta t d)
1694                                   (i386:push-base)))
1695                           (.text accu)
1696                           (list (lambda (f g ta t d)
1697                                   (i386:pop-base)))
1698                           (list (lambda (f g ta t d)
1699                                   (append
1700                                    (i386:sub-base)
1701                                    (i386:xor-zf))))))))
1702
1703         ((le ,a ,b)
1704          (let* ((base ((expr->base info) a))
1705                 (empty (clone base #:text '()))
1706                 (accu ((expr->accu empty) b)))
1707            (clone info #:text
1708                   (append text
1709                           (.text base)
1710                           (list (lambda (f g ta t d)
1711                                   (i386:push-base)))
1712                           (.text accu)
1713                           (list (lambda (f g ta t d)
1714                                   (i386:pop-base)))
1715                           (list (lambda (f g ta t d)
1716                                   (i386:base-sub)))))))
1717
1718         ((lt ,a ,b)
1719          (let* ((base ((expr->base info) a))
1720                 (empty (clone base #:text '()))
1721                 (accu ((expr->accu empty) b)))
1722            (clone info #:text
1723                   (append text
1724                           (.text base)
1725                           (list (lambda (f g ta t d)
1726                                   (i386:push-base)))
1727                           (.text accu)
1728                           (list (lambda (f g ta t d)
1729                                   (i386:pop-base)))
1730                           (list (lambda (f g ta t d)
1731                                   (i386:base-sub)))))))
1732
1733         ;; TODO: byte dinges
1734         ((Xsub ,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         ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1750          (clone info #:text
1751                 (append text
1752                         (list (lambda (f g ta t d)
1753                                 (append
1754                                  (i386:local->accu (local:id (assoc-ref locals a)))
1755                                  (i386:byte-mem->base)
1756                                  (i386:local->accu (local:id (assoc-ref locals b)))
1757                                  (i386:byte-mem->accu)
1758                                  (i386:byte-sub-base)))))))
1759
1760         ;; g_cells[0]
1761         ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
1762          (let* ((value (cstring->number value))
1763                 (type (ident->type info array))
1764                 (size (type->size info type)))
1765            (clone info #:text
1766                   (append text
1767                         ((ident->base info) array)
1768                         (list (lambda (f g ta t d)
1769                                 (append
1770                                  (i386:value->accu (* size index))
1771                                  (if (eq? size 1)
1772                                      (i386:byte-base-mem->accu)
1773                                      (i386:base-mem->accu)))))))))
1774
1775         ;; g_cells[a]
1776         ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1777          (let* ((type (ident->type info array))
1778                 (size (type->size info type)))
1779            (clone info #:text
1780                   (append text
1781                           ((ident->base info) index)
1782                           (list (lambda (f g ta t d)
1783                                   (append
1784                                    (i386:base->accu)
1785                                    (if (< size 4) '()
1786                                        (append
1787                                          (i386:accu+accu)
1788                                          (if (= size 12) (i386:accu+base) '())
1789                                          (i386:accu-shl 2))))))
1790                           ((ident->base info) array)
1791                           (list (lambda (f g ta t d)
1792                                  (if (eq? size 1)
1793                                      (i386:byte-base-mem->accu)
1794                                      (i386:base-mem->accu))))))))
1795
1796         ((return ,expr)
1797          (let ((accu ((expr->accu info) expr)))
1798            (clone accu #:text
1799                   (append (.text accu) (list (lambda (f g ta t d) (i386:ret)))))))
1800
1801         ;; int i;
1802         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1803          (if (.function info)
1804              (clone info #:locals (add-local locals name type 0))
1805              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1806
1807         ;; int i = 0;
1808         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1809          (let ((value (cstring->number value)))
1810            (if (.function info)
1811                (let* ((locals (add-local locals name type 0))
1812                       (info (clone info #:locals locals)))
1813                  (clone info #:text
1814                         (append text
1815                                 ((value->ident info) name value))))
1816                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1817
1818         ;; char c = 'A';
1819         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1820          (if (not (.function info)) decl-barf0)
1821          (let* ((locals (add-local locals name type 0))
1822                 (info (clone info #:locals locals))
1823                 (value (char->integer (car (string->list value)))))
1824            (clone info #:text
1825                   (append text
1826                           ((value->ident info) name value)))))
1827
1828         ;; int i = -1;
1829         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1830          (let ((value (- (cstring->number value))))
1831            (if (.function info)
1832                (let* ((locals (add-local locals name type 0))
1833                       (info (clone info #:locals locals)))
1834                  (clone info #:text
1835                         (append text
1836                                 ((value->ident info) name value))))
1837                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1838
1839         ;; int i = argc;
1840         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1841          (if (not (.function info)) decl-barf2)
1842          (let* ((locals (add-local locals name type 0))
1843                 (info (clone info #:locals locals)))
1844            (clone info #:text
1845                   (append text
1846                           ((ident->accu info) local)
1847                           ((accu->ident info) name)))))
1848
1849         ;; char *p = "t.c";
1850         ;;(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"))))))
1851         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1852          (when (not (.function info))
1853              (stderr "o=~s\n" o)
1854              decl-barf3)
1855          (let* ((locals (add-local locals name type 1))
1856                 (globals (append globals (list (string->global string))))
1857                 (info (clone info #:locals locals #:globals globals)))
1858            (clone info #:text
1859                   (append text
1860                           (list (lambda (f g ta t d)
1861                                   (append
1862                                    (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1863                           ((accu->ident info) name)))))
1864
1865         ;; char *p = 0;
1866         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1867          (let ((value (cstring->number value)))
1868            (if (.function info)
1869                (let* ((locals (add-local locals name type 1))
1870                       (info (clone info #:locals locals)))
1871                  (clone info #:text
1872                         (append text
1873                                 (list (lambda (f g ta t d)
1874                                         (i386:value->accu value)))
1875                                 ((accu->ident info) name))))
1876                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1877
1878         ;; char arena[20000];
1879         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1880          (let ((type (ast->type type)))
1881            (if (.function info)
1882                TODO:decl-array
1883                (let* ((globals (.globals info))
1884                       (count (cstring->number count))
1885                       (size (type->size info type))
1886                       ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1887                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1888                       (globals (append globals (list array))))
1889                  (clone info
1890                         #:globals globals)))))
1891
1892         ;;struct scm *g_cells = (struct scm*)arena;
1893         ((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)))))))
1894          ;;(stderr "0TYPE: ~s\n" type)
1895          (if (.function info)
1896              (let* ((locals (add-local locals name type 1))
1897                     (info (clone info #:locals locals)))
1898                (clone info #:text
1899                       (append text
1900                               ((ident->accu info) name)
1901                               ((accu->ident info) value)))) ;; FIXME: deref?
1902              (let* ((globals (append globals (list (ident->global name type 1 0))))
1903                     (info (clone info #:globals globals)))
1904                (clone info #:text
1905                       (append text
1906                               ((ident->accu info) name)
1907                               ((accu->ident info) value)))))) ;; FIXME: deref?
1908
1909         ;; SCM tmp;
1910         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1911          ;;(stderr  "1TYPE: ~s\n" type)
1912          (if (.function info)
1913              (clone info #:locals (add-local locals name type 0))
1914              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1915
1916         ;; SCM g_stack = 0;
1917         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1918          ;;(stderr  "2TYPE: ~s\n" type)
1919          (let ((value (cstring->number value)))
1920           (if (.function info)
1921               (let* ((locals (add-local locals name type 0))
1922                      (info (clone info #:locals locals)))
1923                 (clone info #:text
1924                        (append text
1925                                ((value->ident info) name value))))
1926               (let ((globals (append globals (list (ident->global name type 0 value)))))
1927                 (clone info #:globals globals)))))
1928
1929         ;; SCM g_stack = 0; // comment
1930         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1931          ((ast->info info) (list-head o (- (length o) 1))))
1932
1933         ;; SCM i = argc;
1934         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1935          ;;(stderr  "3TYPE: ~s\n" type)
1936          (if (.function info)
1937              (let* ((locals (add-local locals name type 0))
1938                     (info (clone info #:locals locals)))
1939                (clone info #:text
1940                       (append text
1941                               ((ident->accu info) local)
1942                               ((accu->ident info) name))))
1943              (let* ((globals (append globals (list (ident->global name type 0 0))))
1944                     (info (clone info #:globals globals)))
1945                (clone info #:text
1946                       (append text
1947                               ((ident->accu info) local)
1948                               ((accu->ident info) name))))))
1949
1950         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1951         ((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))))
1952          (let* ((locals (add-local locals name type 1))
1953                 (info (clone info #:locals locals))
1954                 (empty (clone info #:text '()))
1955                 (accu ((expr->accu empty) initzer)))
1956            (clone info
1957                   #:text
1958                   (append text
1959                           (.text accu)
1960                           ((accu->ident info) name)
1961                           (list (lambda (f g ta t d)
1962                                   (append
1963                                    ;;(i386:value->base t)
1964                                    ;;(i386:accu+base)
1965                                    (i386:value->base ta)
1966                                    (i386:accu+base)))))
1967                   #:locals locals)))
1968
1969         ;; char *p = (char*)g_cells;
1970         ((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)))))))
1971          ;;(stderr  "6TYPE: ~s\n" type)
1972          (if (.function info)
1973              (let* ((locals (add-local locals name type 1))
1974                     (info (clone info #:locals locals)))
1975                (clone info #:text
1976                       (append text
1977                               ((ident->accu info) value)
1978                               ((accu->ident info) name))))
1979              (let* ((globals (append globals (list (ident->global name type 1 0))))
1980                     (here (data-offset name globals))
1981                     (there (data-offset value globals)))
1982                (clone info
1983                       #:globals globals
1984                       #:init (append (.init info)
1985                                      (list (lambda (functions globals ta t d data)
1986                                              (append
1987                                               (list-head data here)
1988                                               ;;; FIXME: type
1989                                               ;;; char *x = arena;
1990                                               (int->bv32 (+ d (data-offset value globals)))
1991                                               ;;; char *y = x;
1992                                               ;;;(list-head (list-tail data there) 4)
1993                                               (list-tail data (+ here 4))))))))))
1994
1995         ;; char *p = g_cells;
1996         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1997          ;;(stderr  "7TYPE: ~s\n" type)
1998          (let ((type (decl->type type)))
1999            ;;(stderr "0DECL: ~s\n" type)
2000            (if (.function info)
2001                (let* ((locals (add-local locals name type  1))
2002                       (info (clone info #:locals locals)))
2003                  (clone info #:text
2004                         (append text
2005                                 ((ident->accu info) value)
2006                                 ((accu->ident info) name))))
2007                (let* ((globals (append globals (list (ident->global name type 1 0))))
2008                       (here (data-offset name globals)))
2009                  (clone info
2010                         #:globals globals
2011                         #:init (append (.init info)
2012                                        (list (lambda (functions globals ta t d data)
2013                                                (append
2014                                                 (list-head data here)
2015                                               ;;; FIXME: type
2016                                               ;;; char *x = arena;p
2017                                                 (int->bv32 (+ d (data-offset value globals)))
2018                                                 (list-tail data (+ here 4)))))))))))
2019
2020         ;; enum
2021         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
2022          (let ((type (enum->type name fields))
2023                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
2024            (clone info
2025                   #:types (append (.types info) (list type))
2026                   #:constants (append constants (.constants info)))))
2027
2028         ;; struct
2029         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
2030          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
2031            ;;(stderr "type: ~a\n" type)
2032            (clone info #:types (append (.types info) (list type)))))
2033
2034         ;; *p++ = b;
2035         ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
2036          (when (not (equal? op "="))
2037            (stderr "OOOPS0.0: op=~s\n" op)
2038            barf)
2039          (let* ((empty (clone info #:text '()))
2040                 (base ((expr->base empty) b)))
2041            (clone info #:text
2042                   (append text
2043                           (.text base)
2044                           ((base->ident-address info) name)
2045                           ((ident-add info) name 1)))))
2046
2047         ;; *p-- = b;
2048         ((expr-stmt (assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b))
2049          (when (not (equal? op "="))
2050            (stderr "OOOPS0.0: op=~s\n" op)
2051            barf)
2052          (let* ((empty (clone info #:text '()))
2053                 (base ((expr->base empty) b)))
2054            (clone info #:text
2055                   (append text
2056                           (.text base)
2057                           ((base->ident-address info) name)
2058                           ((ident-add info) name -1)))))
2059
2060         ;; CAR (x) = 0
2061         ;; TYPE (x) = PAIR;
2062         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
2063          (when (not (equal? op "="))
2064            (stderr "OOOPS0: op=~s\n" op)
2065            barf)
2066          (let* ((empty (clone info #:text '()))
2067                 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
2068                 (base ((expr->base empty) b))
2069                 (type (list "struct" "scm")) ;; FIXME
2070                 (fields (type->description info type))
2071                 (size (type->size info type))
2072                 (field-size 4) ;; FIXME:4, not fixed
2073                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
2074            (clone info #:text (append text
2075                                       (.text expr)
2076                                       (.text base)
2077                                       (list (lambda (f g ta t d)
2078                                               ;;(i386:byte-base->accu-ref) ;; FIXME: size
2079                                               (i386:base->accu-address)
2080                                               ))))))
2081
2082
2083         ;; i = 0;
2084         ;; c = f ();
2085         ;; i = i + 48;
2086         ;; p = g_cell;
2087         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
2088          (when (and (not (equal? op "="))
2089                     (not (equal? op "+="))
2090                     (not (equal? op "-=")))
2091            (stderr "OOOPS1: op=~s\n" op)
2092            barf)
2093          (let* ((empty (clone info #:text '()))
2094                 (base ((expr->base empty) b)))
2095            (clone info #:text (append text
2096                                       (.text base)
2097                                       (if (equal? op "=") '()
2098                                           (append ((ident->accu info) name)
2099                                                   (list (lambda (f g ta t d)
2100                                                           (append
2101                                                            (if (equal? op "+=")
2102                                                                (i386:accu+base)
2103                                                                (i386:accu-base))
2104                                                            (i386:accu->base))))))
2105                                       ;;assign:
2106                                       ((base->ident info) name)))))
2107
2108         ;; *p = 0;
2109         ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
2110          (when (not (equal? op "="))
2111            (stderr "OOOPS2: 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                                       ;;assign:
2118                                       ((base->ident-address info) array)))))
2119
2120         ;; g_cells[0] = 65;
2121         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2122          (when (not (equal? op "="))
2123            (stderr "OOOPS3: op=~s\n" op)
2124            barf)
2125          (let* ((index (cstring->number index))
2126                 (empty (clone info #:text '()))
2127                 (base ((expr->base empty) b))
2128                 (type (ident->type info array))
2129                 (size (type->size info type))
2130                 (ptr (ident->pointer info array)))
2131            (clone info #:text
2132                   (append text
2133                          (.text base)
2134                          (list (lambda (f g ta t d)
2135                                  (i386:push-base)))
2136                          (list (lambda (f g ta t d)
2137                                  (append
2138                                   (i386:value->base index)
2139                                   (i386:base->accu)
2140                                   (if (eq? size 1) '()
2141                                       (append
2142                                         (if (> size 4) (i386:accu+accu) '())
2143                                         (if (> size 8) (i386:accu+base) '())
2144                                         (i386:accu-shl 2))))))
2145                          ((ident->base info) array)
2146                          (list (lambda (f g ta t d)
2147                                  (i386:accu+base)))
2148                          (list (lambda (f g ta t d)
2149                                  (i386:pop-base)))
2150                          (if (eq? size 1) (list (lambda (f g ta t d)
2151                                                   (i386:byte-base->accu-address)))
2152                              (append
2153                               (list (lambda (f g ta t d)
2154                                       (i386:base-address->accu-address)))
2155                               (if (> size 4)
2156                                   (list (lambda (f g ta t d)
2157                                           (append
2158                                            (i386:accu+n 4)
2159                                            (i386:base+n 4)
2160                                            (i386:base-address->accu-address))))
2161                                   '())
2162                               (if (> size 8)
2163                                   (list (lambda (f g ta t d)
2164                                           (append
2165                                            (i386:accu+n 4)
2166                                            (i386:base+n 4)
2167                                            (i386:base-address->accu-address))))
2168                                   '())))))))
2169
2170         ;; g_cells[i] = c;
2171         ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2172          ;;(stderr "pointer_cells4[]: ~s\n" array)
2173          (when (not (equal? op "="))
2174            (stderr "OOOPS4: op=~s\n" op)
2175            barf)
2176          (let* ((empty (clone info #:text '()))
2177                 (base ((expr->base empty) b))
2178                 (type (ident->type info array))
2179                 (size (type->size info type))
2180                 (ptr (ident->pointer info array)))
2181            (clone info #:text
2182                   (append text
2183                           (.text base)
2184                           (list (lambda (f g ta t d)
2185                                   (i386:push-base)))
2186                           ((ident->base info) index)
2187                           (list (lambda (f g ta t d)
2188                                   (append
2189                                    (i386:base->accu)
2190                                    (if (eq? size 1) '()
2191                                        (append
2192                                          (if (> size 4) (i386:accu+accu) '())
2193                                          (if (> size 8) (i386:accu+base) '())
2194                                          (i386:accu-shl 2))))))
2195                           ((ident->base info) array)
2196                           (list (lambda (f g ta t d)
2197                                   (i386:accu+base)))
2198                          (list (lambda (f g ta t d)
2199                                  (i386:pop-base)))
2200                          (if (eq? size 1) (list (lambda (f g ta t d)
2201                                                   (i386:byte-base->accu-address)))
2202                              (append
2203                               (list (lambda (f g ta t d)
2204                                       (i386:base-address->accu-address)))
2205                               (if (> size 4)
2206                                   (list (lambda (f g ta t d)
2207                                           (append
2208                                            (i386:accu+n 4)
2209                                            (i386:base+n 4)
2210                                            (i386:base-address->accu-address))))
2211                                   '())
2212                               (if (> size 8)
2213                                   (list (lambda (f g ta t d)
2214                                           (append
2215                                            (i386:accu+n 4)
2216                                            (i386:base+n 4)
2217                                            (i386:base-address->accu-address))))
2218                                   '())))))))
2219
2220         ;; g_functions[g_function++] = g_foo;
2221         ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
2222          (when (not (equal? op "="))
2223            (stderr "OOOPS5: op=~s\n" op)
2224            barf)
2225          (let* ((empty (clone info #:text '()))
2226                 (base ((expr->base empty) b))
2227                 (type (ident->type info array))
2228                 (size (type->size info type))
2229                 (ptr (ident->pointer info array)))
2230            (clone info #:text
2231                   (append text
2232                           (.text base)
2233                           (list (lambda (f g ta t d)
2234                                   (i386:push-base)))
2235                           ((ident->base info) index)
2236                           (list (lambda (f g ta t d)
2237                                   (append
2238                                    (i386:base->accu)
2239                                    (if (eq? size 1) '()
2240                                        (append
2241                                          (if (> size 4) (i386:accu+accu) '())
2242                                          (if (> size 8) (i386:accu+base) '())
2243                                          (i386:accu-shl 2))))))
2244                           ((ident->base info) array)
2245                           (list (lambda (f g ta t d)
2246                                   (i386:accu+base)))
2247                          (list (lambda (f g ta t d)
2248                                  (i386:pop-base)))
2249                          (if (eq? size 1) (list (lambda (f g ta t d)
2250                                                   (i386:byte-base->accu-address)))
2251                              (append
2252                               (list (lambda (f g ta t d)
2253                                       (i386:base-address->accu-address)))
2254                               (if (> size 4)
2255                                   (list (lambda (f g ta t d)
2256                                           (append
2257                                            (i386:accu+n 4)
2258                                            (i386:base+n 4)
2259                                            (i386:base-address->accu-address))))
2260                                   '())
2261                               (if (> size 8)
2262                                   (list (lambda (f g ta t d)
2263                                           (append
2264                                            (i386:accu+n 4)
2265                                            (i386:base+n 4)
2266                                            (i386:base-address->accu-address))))
2267                                   '())))
2268                          ((ident-add info) index 1)))))
2269
2270         ;; DECL
2271         ;;
2272         ;; struct f = {...};
2273         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2274          (let* ((type (decl->type type))
2275                 ;;(foo (stderr "1DECL: ~s\n" type))
2276                 (fields (type->description info type))
2277                 (size (type->size info type))
2278                 (field-size 4))  ;; FIXME:4, not fixed
2279            ;;(stderr  "7TYPE: ~s\n" type)
2280            (if (.function info)
2281                (let* ((globals (append globals (filter-map initzer->global initzers)))
2282                       (locals (let loop ((fields (cdr fields)) (locals locals))
2283                                 (if (null? fields) locals
2284                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2285                       (locals (add-local locals name type -1))
2286                       (info (clone info #:locals locals #:globals globals))
2287                       (empty (clone info #:text '())))
2288                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2289                    (if (null? fields) info
2290                        (let ((offset (* field-size (car fields)))
2291                              (initzer (car initzers)))
2292                          (loop (cdr fields) (cdr initzers)
2293                                (clone info #:text
2294                                       (append
2295                                        (.text info)
2296                                        ((ident->accu info) name)
2297                                        (list (lambda (f g ta t d)
2298                                                (append
2299                                                 (i386:accu->base))))
2300                                        (.text ((expr->accu empty) initzer))
2301                                        (list (lambda (f g ta t d)
2302                                                (i386:accu->base-address+n offset))))))))))
2303                (let* ((globals (append globals (filter-map initzer->global initzers)))
2304                       (global (make-global name type -1 (string->list (make-string size #\nul))))
2305                       (globals (append globals (list global)))
2306                       (here (data-offset name globals))
2307                       (info (clone info #:globals globals))
2308                       (field-size 4))
2309                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2310                    (if (null? fields) info
2311                        (let ((offset (* field-size (car fields)))
2312                              (initzer (car initzers)))
2313                          (loop (cdr fields) (cdr initzers)
2314                                (clone info #:init
2315                                       (append
2316                                        (.init info)
2317                                        (list (lambda (functions globals ta t d data)
2318                                                (append
2319                                                 (list-head data (+ here offset))
2320                                                 (initzer->data info functions globals ta t d (car initzers))
2321                                                 (list-tail data (+ here offset field-size)))))))))))))))
2322
2323
2324         ;;char cc = g_cells[c].cdr;  ==> generic?
2325         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2326          (let ((type (decl->type type)))
2327            (if (.function info)
2328                (let* ((locals (add-local locals name type 0))
2329                       (info (clone info #:locals locals)))
2330                  (clone info #:text
2331                         (append (.text ((expr->accu info) initzer))
2332                                 ((accu->ident info) name))))
2333                (let* ((globals (append globals (list (ident->global name type 1 0))))
2334                       (here (data-offset name globals)))
2335                  (clone info
2336                         #:globals globals
2337                         #:init (append (.init info)
2338                                        (list (lambda (functions globals ta t d data)
2339                                                (append
2340                                                 (list-head data here)
2341                                                 (initzer->data info functions globals ta t d initzer)
2342                                                 (list-tail data (+ here 4)))))))))))
2343
2344
2345         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2346          info)
2347
2348         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
2349          info)
2350
2351         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2352          (let ((types (.types info)))
2353            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
2354
2355         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2356          (format (current-error-port) "SKIP: typedef=~s\n" o)
2357          info)
2358
2359         ((decl (@ ,at))
2360          (format (current-error-port) "SKIP: at=~s\n" o)
2361          info)
2362
2363         ((decl . _)
2364          (format (current-error-port) "SKIP: decl statement=~s\n" o)
2365          barf
2366          info)
2367
2368         (_
2369          (format (current-error-port) "SKIP: statement=~s\n" o)
2370          barf
2371          info)))))
2372
2373 (define (initzer->data info functions globals ta t d o)
2374   (pmatch o
2375     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2376     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2377     ((initzer (ref-to (p-expr (ident ,name))))
2378      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2379      (int->bv32 (+ ta (function-offset name functions))))
2380     ((initzer (p-expr (ident ,name)))
2381      (let ((value (assoc-ref (.constants info) name)))
2382        (int->bv32 value)))
2383     ((initzer (p-expr (string ,string)))
2384      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2385     (_ (stderr "initzer->data:SKIP: ~s\n" o)
2386        barf
2387      (int->bv32 0))))
2388
2389 (define (info->exe info)
2390   (display "dumping elf\n" (current-error-port))
2391   (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2392
2393 (define (.formals o)
2394   (pmatch o
2395     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2396     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2397     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2398        barf)))
2399
2400 (define (formal->text n)
2401   (lambda (o i)
2402     ;;(i386:formal i n)
2403     '()
2404     ))
2405
2406 (define (formals->text o)
2407   (pmatch o
2408     ((param-list . ,formals)
2409      (let ((n (length formals)))
2410        (list (lambda (f g ta t d)
2411                (append
2412                 (i386:function-preamble)
2413                 (append-map (formal->text n) formals (iota n))
2414                 (i386:function-locals))))))
2415     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2416        barf)))
2417
2418 (define (formal:ptr o)
2419   (pmatch o
2420     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2421      1)
2422     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2423      0)
2424     (_
2425      (stderr "formal:ptr[~a] => 0\n" o)
2426      0)))
2427
2428 (define (formals->locals o)
2429   (pmatch o
2430     ((param-list . ,formals)
2431      (let ((n (length formals)))
2432        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2433     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2434        barf)))
2435
2436 (define (function->info info)
2437   (lambda (o)
2438     ;;(stderr "\n")
2439     ;;(stderr "formals=~a\n" (.formals o))
2440     (let* ((name (.name o))
2441            (text (formals->text (.formals o)))
2442            (locals (formals->locals (.formals o))))
2443       (format (current-error-port) "compiling ~a\n" name)
2444       ;;(stderr "locals=~a\n" locals)
2445       (let loop ((statements (.statements o))
2446                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2447         (if (null? statements) (clone info
2448                                       #:function #f
2449                                       #:functions (append (.functions info) (list (cons name (.text info)))))
2450             (let* ((statement (car statements)))
2451               (loop (cdr statements)
2452                     ((ast->info info) (car statements)))))))))
2453
2454 (define (ast-list->info info)
2455   (lambda (elements)
2456     (let loop ((elements elements) (info info))
2457       (if (null? elements) info
2458           (loop (cdr elements) ((ast->info info) (car elements)))))))
2459
2460 (define (compile)
2461   (let* ((ast (mescc))
2462          (info (make <info>
2463                  #:functions i386:libc
2464                  #:types i386:type-alist))
2465          (ast (append libc ast))
2466          (info ((ast->info info) ast))
2467          (info ((ast->info info) _start)))
2468     (info->exe info)))