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