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