module/language/c99/compiler.mes

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