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