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