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 (mes pmatch))
  34   (mes-use-module (nyacc lang c99 parser))
  35   (mes-use-module (mes elf-util))
  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 (mescc)
  50   (parse-c99
  51    #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
  52    #:cpp-defs `(
  53                 "_POSIX_SOURCE=0"
  54                 "__GNUC__=0"
  55                 "__MESC__=1"
  56                 "__NYACC__=1" ;; REMOVEME
  57                 "STDIN=0"
  58                 "STDOUT=1"
  59                 "STDERR=2"
  60                 "O_RDONLY=0"
  61
  62                 "INT_MIN=-2147483648"
  63                 "INT_MAX=2147483647"
  64
  65                 ,(string-append "DATADIR=\"" %datadir "\"")
  66                 ,(string-append "DOCDIR=\"" %docdir "\"")
  67                 ,(string-append "PREFIX=\"" %prefix "\"")
  68                 ,(string-append "MODULEDIR=\"" %moduledir "\"")
  69                 ,(string-append "VERSION=\"" %version "\"")
  70                 )
  71    #:mode 'code))
  72
  73 (define (write-any x)
  74   (write-char (cond ((char? x) x)
  75                     ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
  76                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
  77                     ((procedure? x)
  78                      (stderr "write-any: proc: ~a\n" x)
  79                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
  80                      barf)
  81                     (else (stderr "write-any: ~a\n" x) barf))))
  82
  83 (define (ast:function? o)
  84   (and (pair? o) (eq? (car o) 'fctn-defn)))
  85
  86 (define (.name o)
  87   (pmatch o
  88     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
  89     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
  90     ((param-decl _ (param-declr (ident ,name))) name)
  91     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
  92     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
  93     (_
  94      (format (current-error-port) "SKIP: .name =~a\n" o))))
  95
  96 (define (.type o)
  97   (pmatch o
  98     ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
  99     ((param-decl ,type _) type)
 100     (_
 101      (format (current-error-port) "SKIP: .type =~a\n" o))))
 102
 103 (define (.statements o)
 104   (pmatch o
 105     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
 106     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
 107
 108 (define <info> '<info>)
 109 (define <types> '<types>)
 110 (define <constants> '<constants>)
 111 (define <functions> '<functions>)
 112 (define <globals> '<globals>)
 113 (define <init> '<init>)
 114 (define <locals> '<locals>)
 115 (define <function> '<function>)
 116 (define <text> '<text>)
 117
 118 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()))
 119   (pmatch o
 120     (<info> (list <info>
 121                   (cons <types> types)
 122                   (cons <constants> constants)
 123                   (cons <functions> functions)
 124                   (cons <globals> globals)
 125                   (cons <init> init)
 126                   (cons <locals> locals)
 127                   (cons <function> function)
 128                   (cons <text> text)))))
 129
 130 (define (.types o)
 131   (pmatch o
 132     ((<info> . ,alist) (assq-ref alist <types>))))
 133
 134 (define (.constants o)
 135   (pmatch o
 136     ((<info> . ,alist) (assq-ref alist <constants>))))
 137
 138 (define (.functions o)
 139   (pmatch o
 140     ((<info> . ,alist) (assq-ref alist <functions>))))
 141
 142 (define (.globals o)
 143   (pmatch o
 144     ((<info> . ,alist) (assq-ref alist <globals>))))
 145
 146 (define (.init o)
 147   (pmatch o
 148     ((<info> . ,alist) (assq-ref alist <init>))))
 149
 150 (define (.locals o)
 151   (pmatch o
 152     ((<info> . ,alist) (assq-ref alist <locals>))))
 153
 154 (define (.function o)
 155   (pmatch o
 156     ((<info> . ,alist) (assq-ref alist <function>))))
 157
 158 (define (.text o)
 159   (pmatch o
 160     ((<info> . ,alist) (assq-ref alist <text>))))
 161
 162 (define (info? o)
 163   (and (pair? o) (eq? (car o) <info>)))
 164
 165 (define (clone o . rest)
 166   (cond ((info? o)
 167          (let ((types (.types o))
 168                (constants (.constants o))
 169                (functions (.functions o))
 170                (globals (.globals o))
 171                (init (.init o))
 172                (locals (.locals o))
 173                (function (.function o))
 174                (text (.text o)))
 175            (let-keywords rest
 176                          #f
 177                          ((types types)
 178                           (constants constants)
 179                           (functions functions)
 180                           (globals globals)
 181                           (init init)
 182                           (locals locals)
 183                           (function function)
 184                           (text text))
 185                          (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text))))))
 186
 187 (define (push-global globals)
 188   (lambda (o)
 189     (list
 190      (lambda (f g ta t d)
 191        (i386:push-global (+ (data-offset o g) d))))))
 192
 193 (define (push-local locals)
 194   (lambda (o)
 195     (wrap-as (i386:push-local (local:id o)))))
 196
 197 (define (push-global-address globals)
 198   (lambda (o)
 199     (list
 200      (lambda (f g ta t d)
 201        (i386:push-global-address (+ (data-offset o g) d))))))
 202
 203 (define (push-local-address locals)
 204   (lambda (o)
 205     (wrap-as (i386:push-local-address (local:id o)))))
 206
 207 (define push-global-de-ref push-global)
 208
 209 (define (push-local-de-ref locals)
 210   (lambda (o)
 211     (wrap-as (i386:push-local-de-ref (local:id o)))))
 212
 213 (define (string->global string)
 214   (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
 215
 216 (define (ident->global name type pointer value)
 217   (make-global name type pointer (int->bv32 value)))
 218
 219 (define (make-local name type pointer id)
 220   (cons name (list type pointer id)))
 221 (define local:type car)
 222 (define local:pointer cadr)
 223 (define local:id caddr)
 224
 225 (define (push-ident info)
 226   (lambda (o)
 227     (let ((local (assoc-ref (.locals info) o)))
 228       (if local ((push-local (.locals info)) local)
 229           (let ((global (assoc-ref (.globals info) o)))
 230             (if global
 231                 ((push-global (.globals info)) o) ;; FIXME: char*/int
 232                 (let ((constant (assoc-ref (.constants info) o)))
 233                   (if constant
 234                       (wrap-as (append (i386:value->accu constant)
 235                                        (i386:push-accu)))
 236                       TODO:push-function))))))))
 237
 238 (define (push-ident-address info)
 239   (lambda (o)
 240     (let ((local (assoc-ref (.locals info) o)))
 241       (if local ((push-local-address (.locals info)) local)
 242           ((push-global-address (.globals info)) o)))))
 243
 244 (define (push-ident-de-ref info)
 245   (lambda (o)
 246     (let ((local (assoc-ref (.locals info) o)))
 247       (if local ((push-local-de-ref (.locals info)) local)
 248           ((push-global-de-ref (.globals info)) o)))))
 249
 250 (define (expr->arg info)
 251   (lambda (o)
 252     (let ((info ((expr->accu info) o)))
 253       (append-text info (wrap-as (i386:push-accu))))))
 254
 255 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
 256   (lambda (o)
 257     (let ((text (.text info)))
 258       ;;(stderr  "expr->arg o=~s\n" o)
 259       (pmatch o
 260
 261         ((p-expr (string ,string))
 262          (append-text info ((push-global-address info) (add-s:-prefix string))))
 263
 264         ((p-expr (ident ,name))
 265          (append-text info ((push-ident info) name)))
 266
 267         ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
 268                           (abs-declr (pointer)))
 269                ,cast)
 270          ((expr->arg info) cast))
 271
 272         ((de-ref (p-expr (ident ,name)))
 273          (append-text info ((push-ident-de-ref info) name)))
 274
 275         ((ref-to (p-expr (ident ,name)))
 276          (append-text info ((push-ident-address info) name)))
 277
 278         (_ (append-text ((expr->accu info) o)
 279                         (wrap-as (i386:push-accu))))))))
 280
 281 ;; FIXME: see ident->base
 282 (define (ident->accu info)
 283   (lambda (o)
 284     (let ((local (assoc-ref (.locals info) o))
 285           (global (assoc-ref (.globals info) o))
 286           (constant (assoc-ref (.constants info) o)))
 287       ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
 288       ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
 289       ;; (stderr "globals: ~a\n" (.globals info))
 290       ;; (if (and (not global) (not (local:id local)))
 291       ;;     (stderr "globals: ~a\n" (map car (.globals info))))
 292       (if local
 293           (let* ((ptr (local:pointer local))
 294                  (type (ident->type info o))
 295                  (size (and type (type->size info type))))
 296             ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
 297             ;;(stderr "type: ~s\n" type)
 298             ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
 299             ;;(stderr "locals: ~s\n" locals)
 300             (case ptr
 301               ((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
 302               ((1) (wrap-as (i386:local->accu (local:id local))))
 303               (else
 304                (wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
 305                             (i386:local->accu (local:id local)))))))
 306           (if global
 307               (let ((ptr (ident->pointer info o)))
 308                 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
 309                 (case ptr
 310                   ((-1) (list (lambda (f g ta t d)
 311                                 (i386:global->accu (+ (data-offset o g) d)))))
 312                   (else (list (lambda (f g ta t d)
 313                                 (i386:global-address->accu (+ (data-offset o g) d)))))))
 314               (if constant (wrap-as (i386:value->accu constant))
 315                   (list (lambda (f g ta t d)
 316                           (i386:global->accu (+ ta (function-offset o f)))))))))))
 317
 318 (define (value->accu v)
 319   (wrap-as (i386:value->accu v)))
 320
 321 (define (accu->ident info)
 322   (lambda (o)
 323     (let ((local (assoc-ref (.locals info) o)))
 324       (if local (wrap-as (i386:accu->local (local:id local)))
 325           (list (lambda (f g ta t d)
 326                   (i386:accu->global (+ (data-offset o g) d))))))))
 327
 328 (define (base->ident info)
 329   (lambda (o)
 330     (let ((local (assoc-ref (.locals info) o)))
 331       (if local (wrap-as (i386:base->local (local:id local)))
 332           (list (lambda (f g ta t d)
 333                   (i386:base->global (+ (data-offset o g) d))))))))
 334
 335 (define (base->ident-address info)
 336   (lambda (o)
 337     (let ((local (assoc-ref (.locals info) o)))
 338       (if local (wrap-as (append (i386:local->accu (local:id local))
 339                                  (i386:byte-base->accu-address)))
 340           TODO:base->ident-address-global))))
 341
 342 (define (value->ident info)
 343   (lambda (o value)
 344     (let ((local (assoc-ref (.locals info) o)))
 345       (if local (wrap-as (i386:value->local (local:id local) value))
 346           (list (lambda (f g ta t d)
 347                   (i386:value->global (+ (data-offset o g) d) value)))))))
 348
 349 (define (ident-add info)
 350   (lambda (o n)
 351     (let ((local (assoc-ref (.locals info) o)))
 352       (if local (wrap-as (i386:local-add (local:id local) n))
 353           (list (lambda (f g ta t d)
 354                   (i386:global-add (+ (data-offset o g) d) n)))))))
 355
 356 ;; FIXME: see ident->accu
 357 (define (ident->base info)
 358   (lambda (o)
 359     (let ((local (assoc-ref (.locals info) o)))
 360       ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
 361       (if local
 362           (let* ((ptr (local:pointer local))
 363                  (type (ident->type info o))
 364                  (size (and type (type->size info type))))
 365             (case ptr
 366               ((-1) (wrap-as (i386:local-ptr->base (local:id local))))
 367               ((1) (wrap-as (i386:local->base (local:id local))))
 368               (else
 369                (wrap-as (if (= size 1) (i386:byte-local->base (local:id local))
 370                             (i386:local->base (local:id local)))))))
 371           (let ((global (assoc-ref (.globals info) o) ))
 372             (if global
 373                 (let ((ptr (ident->pointer info o)))
 374                   ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
 375                   (case ptr
 376                     ((-1) (list (lambda (f g ta t d)
 377                                   (i386:global->base (+ (data-offset o g) d)))))
 378                     (else (list (lambda (f g ta t d)
 379                                   (i386:global-address->base (+ (data-offset o g) d)))))))
 380                 (let ((constant (assoc-ref (.constants info) o)))
 381                   (if constant (wrap-as (i386:value->base constant))
 382                       (list (lambda (f g ta t d)
 383                               (i386:global->base (+ ta (function-offset o f)))))))))))))
 384
 385 (define (expr->accu info)
 386   (lambda (o)
 387     (let ((locals (.locals info))
 388           (constants (.constants info))
 389           (text (.text info))
 390           (globals (.globals info)))
 391       (define (add-local locals name type pointer)
 392         (let* ((id (1+ (length (filter local? (map cdr locals)))))
 393                (locals (cons (make-local name type pointer id) locals)))
 394           locals))
 395       ;; (stderr "expr->accu o=~a\n" o)
 396       (pmatch o
 397         ((p-expr (string ,string))
 398          (append-text info (list (lambda (f g ta t d)
 399                                    (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))
 400         ((p-expr (fixed ,value))
 401          (append-text info (value->accu (cstring->number value))))
 402         ((p-expr (ident ,name))
 403          (append-text info ((ident->accu info) name)))
 404
 405         ((initzer ,initzer) ((expr->accu info) initzer))
 406         ((ref-to (p-expr (ident ,name)))
 407          (append-text info ((ident->accu info) name)))
 408
 409         ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
 410          (let* ((type (list "struct" name))
 411                 (fields (or (type->description info type) '()))
 412                 (size (type->size info type)))
 413            (append-text info (wrap-as (i386:value->accu size)))))
 414
 415         ;; c+p expr->arg
 416         ;; g_cells[<expr>]
 417         ((array-ref ,index (p-expr (ident ,array)))
 418          (let* ((type (ident->type info array))
 419                 (size (type->size info type))
 420                 (info ((expr->accu* info) o)))
 421            (append-text info (wrap-as (append (case size
 422                                                 ((1) (i386:byte-mem->accu))
 423                                                 ((4) (i386:mem->accu))
 424                                                 (else '())))))))
 425
 426         ;; f.field
 427         ((d-sel (ident ,field) (p-expr (ident ,array)))
 428          (let* ((type (ident->type info array))
 429                 (fields (type->description info type))
 430                 (field-size 4) ;; FIXME:4, not fixed
 431                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 432                 (text (.text info)))
 433            (append-text info (append ((ident->accu info) array)
 434                                      (wrap-as (i386:mem+n->accu offset))))))
 435
 436         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
 437          (let* ((type (ident->type info array))
 438                 (fields (or (type->description info type) '()))
 439                 (field-size 4) ;; FIXME:4, not fixed
 440                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
 441                           (begin
 442                             (stderr "no field:~a\n" field)
 443                             '())))
 444                 (offset (* field-size (1- (length rest))))
 445                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
 446            (append-text info (wrap-as (i386:mem+n->accu offset)))))
 447
 448         ;;; FIXME: FROM INFO ...only zero?!
 449         ((p-expr (fixed ,value))
 450          (let ((value (cstring->number value)))
 451            (append-text info (wrap-as (i386:value->accu value)))))
 452
 453         ((p-expr (char ,char))
 454          (let ((char (char->integer (car (string->list char)))))
 455            (append-text info (wrap-as (i386:value->accu char)))))
 456
 457         ((p-expr (ident ,name))
 458          (append-text info ((ident->accu info) name)))
 459
 460         ((de-ref (p-expr (ident ,name)))
 461          (let* ((type (ident->type info name))
 462                 (size (and type (type->size info type))))
 463            (append-text info (append ((ident->accu info) name)
 464                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
 465                                                   (i386:mem->accu)))))))
 466
 467         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
 468          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
 469                                    (append-text info (wrap-as (asm->hex arg0))))
 470              (let* ((globals (append globals (filter-map expr->global expr-list)))
 471                     (info (clone info #:globals globals))
 472                     (text-length (length text))
 473                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
 474                                  (if (null? expressions) info
 475                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
 476                     (text (.text args-info))
 477                     (n (length expr-list)))
 478                (if (and (not (assoc-ref locals name))
 479                         (assoc-ref (.functions info) name))
 480                    (clone args-info #:text
 481                           (append text
 482                                   (list (lambda (f g ta t d)
 483                                           (i386:call f g ta t d (+ t (function-offset name f)) n))))
 484                           #:globals globals)
 485                    (let* ((empty (clone info #:text '()))
 486                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
 487                      (clone args-info #:text
 488                             (append text
 489                                     (.text accu)
 490                                     (list (lambda (f g ta t d)
 491                                             (i386:call-accu f g ta t d n))))
 492                             #:globals globals))))))
 493
 494         ((fctn-call ,function (expr-list . ,expr-list))
 495          (let* ((globals (append globals (filter-map expr->global expr-list)))
 496                 (info (clone info #:globals globals))
 497                 (text-length (length text))
 498                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
 499                              (if (null? expressions) info
 500                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
 501                 (text (.text args-info))
 502                 (n (length expr-list))
 503                 (empty (clone info #:text '()))
 504                 (accu ((expr->accu empty) function)))
 505            (clone info #:text
 506                   (append text
 507                           (.text accu)
 508                           (list (lambda (f g ta t d)
 509                                   (i386:call-accu f g ta t d n))))
 510                   #:globals globals)))
 511
 512         ((cond-expr . ,cond-expr)
 513          ((ast->info info) `(expr-stmt ,o)))
 514
 515         ((post-inc (p-expr (ident ,name)))
 516          (append-text info (append ((ident->accu info) name)
 517                                    ((ident-add info) name 1))))
 518
 519         ((post-dec (p-expr (ident ,name)))
 520          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
 521          (append-text info (append ((ident->accu info) name)
 522                                    ((ident-add info) name -1))))
 523
 524         ((pre-inc (p-expr (ident ,name)))
 525          (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
 526          (append-text info (append ((ident-add info) name 1)
 527                                    ((ident->accu info) name))))
 528
 529         ((pre-dec (p-expr (ident ,name)))
 530          (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
 531          (append-text info (append ((ident-add info) name -1)
 532                                    ((ident->accu info) name))))
 533
 534         ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
 535         ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
 536         ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
 537         ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
 538         ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
 539         ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
 540         ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
 541         ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
 542
 543         ((not ,expr)
 544          (let* ((test-info ((ast->info info) expr)))
 545            (clone info #:text
 546                   (append (.text test-info)
 547                           (wrap-as (i386:accu-not)))
 548                   #:globals (.globals test-info))))
 549
 550         ((neg (p-expr (fixed ,value)))
 551          (append-text info (value->accu (- (cstring->number value)))))
 552
 553         ((neg (p-expr (ident ,name)))
 554          (append-text info (append ((ident->base info) name)
 555                                    (wrap-as (i386:value->accu 0))
 556                                    (wrap-as (i386:sub-base)))))
 557
 558         ((eq ,a ,b) ((binop->accu info) a b (i386:sub-base)))
 559         ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
 560         ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
 561         ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base)
 562                                                     (i386:xor-zf))))
 563         ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
 564         ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
 565
 566         ((cast ,cast ,o)
 567          ((expr->accu info) o))
 568
 569         ;; *p++ = b;
 570         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
 571          (when (not (equal? op "="))
 572            (stderr "OOOPS0.0: op=~s\n" op)
 573            barf)
 574          (let ((info ((expr->base info) b)))
 575            (append-text info (append ((base->ident-address info) name)
 576                                      ((ident->accu info) name)
 577                                      ((ident-add info) name 1)))))
 578
 579         ;; *p-- = b;
 580         ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
 581          (when (not (equal? op "="))
 582            (stderr "OOOPS0.0: op=~s\n" op)
 583            barf)
 584          (let ((info ((expr->base info) b)))
 585            (append-text info (append ((base->ident-address info) name)
 586                                      ((ident->accu info) name)
 587                                      ((ident-add info) name -1)))))
 588
 589         ;; CAR (x) = 0
 590         ;; TYPE (x) = PAIR;
 591         ((assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b)
 592          (when (not (equal? op "="))
 593            (stderr "OOOPS0: op=~s\n" op)
 594            barf)
 595          (let* (;;(empty (clone info #:text '()))
 596                 ;;(expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
 597                 (info ((expr->accu info) b))
 598                 (info (append-text info (wrap-as (i386:push-accu))))
 599                 (info ((expr->accu* info) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
 600                 (info (append-text info (wrap-as (i386:pop-base))))
 601                 (type (list "struct" "scm")) ;; FIXME
 602                 (fields (type->description info type))
 603                 (size (type->size info type))
 604                 (field-size 4) ;; FIXME:4, not fixed
 605                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
 606            (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
 607
 608
 609         ;; i = 0;
 610         ;; c = f ();
 611         ;; i = i + 48;
 612         ;; p = g_cell;
 613         ((assn-expr (p-expr (ident ,name)) (op ,op) ,b)
 614          (when (and (not (equal? op "="))
 615                     (not (equal? op "+="))
 616                     (not (equal? op "-=")))
 617            (stderr "OOOPS1: op=~s\n" op)
 618            barf)
 619          (let ((info ((expr->base info) b)))
 620            (append-text info (append (if (equal? op "=") '()
 621                                          (append ((ident->accu info) name)
 622                                                  (wrap-as (append (if (equal? op "+=") (i386:accu+base)
 623                                                                       (i386:accu-base))
 624                                                                   (i386:accu->base)))))
 625                                      ;;assign:
 626                                      ((base->ident info) name)
 627                                      (wrap-as (i386:base->accu))))))
 628
 629         ;; *p = 0;
 630         ((assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b)
 631          (when (not (equal? op "="))
 632            (stderr "OOOPS2: op=~s\n" op)
 633            barf)
 634          (let ((info ((expr->base info) b)))
 635            (append-text info (append ;;assign:
 636                                      ((base->ident-address info) array)
 637                                      (wrap-as (i386:base->accu))))))
 638
 639         ;; g_cells[<expr>] = <expr>;
 640         ((assn-expr (array-ref ,index (p-expr (ident ,array))) (op ,op) ,b)
 641          (when (not (equal? op "="))
 642            (stderr "OOOPS3: op=~s\n" op)
 643            barf)
 644          (let* ((info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
 645                 (info ((expr->base info) b))
 646                 (type (ident->type info array))
 647                 (size (type->size info type))
 648                 (ptr (ident->pointer info array)))
 649            (append-text info (append
 650                               (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
 651                                   (append
 652                                    (wrap-as (i386:base-address->accu-address))
 653                                    (if (<= size 4) '()
 654                                        (wrap-as (append (i386:accu+n 4)
 655                                                         (i386:base+n 4)
 656                                                         (i386:base-address->accu-address))))
 657                                    (if (<= size 8) '()
 658                                        (wrap-as (append (i386:accu+n 4)
 659                                                         (i386:base+n 4)
 660                                                         (i386:base-address->accu-address))))))))))
 661
 662         (_
 663          (format (current-error-port) "SKIP: expr->accu=~s\n" o)
 664          barf
 665          info)))))
 666
 667 (define (expr->base info)
 668   (lambda (o)
 669     (let* ((info (append-text info (wrap-as (i386:push-accu))))
 670            (info ((expr->accu info) o))
 671            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
 672       info)))
 673
 674 (define (binop->accu info)
 675   (lambda (a b c)
 676     (let* ((info ((expr->accu info) a))
 677            (info ((expr->base info) b)))
 678       (append-text info (wrap-as c)))))
 679
 680 (define (append-text info text)
 681   (clone info #:text (append (.text info) text)))
 682
 683 (define (wrap-as o)
 684   (list (lambda (f g ta t d) o)))
 685
 686 (define (expr->accu* info)
 687   (lambda (o)
 688     ;; (stderr "expr->accu* o=~s\n" o)
 689
 690     (pmatch o
 691       ;; g_cells[<expr>]
 692       ((array-ref ,index (p-expr (ident ,array)))
 693        (let* ((info ((expr->accu info) index))
 694               (type (ident->type info array))
 695               (size (type->size info type)))
 696          (append-text info (append (wrap-as (append (i386:accu->base)
 697                                                     (if (eq? size 1) '()
 698                                                         (append
 699                                                          (if (<= size 4) '()
 700                                                              (i386:accu+accu))
 701                                                          (if (<= size 8) '()
 702                                                              (i386:accu+base))
 703                                                          (i386:accu-shl 2)))))
 704                                    ((ident->base info) array)
 705                                    (wrap-as (i386:accu+base))))))
 706
 707       ;; g_cells[<expr>].type
 708       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
 709        (let* ((type (ident->type info array))
 710               (fields (or (type->description info type) '()))
 711               (field-size 4) ;; FIXME:4, not fixed
 712               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 713               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
 714          (append-text info (wrap-as (append (i386:accu+value offset))))))
 715
 716       ((d-sel (ident ,field) (p-expr (ident ,name)))
 717        (let* ((type (ident->type info name))
 718               (fields (or (type->description info type) '()))
 719               (field-size 4) ;; FIXME
 720               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
 721               (text (.text info)))
 722          (append-text info (append ((ident->accu info) name)
 723                                    (wrap-as (i386:accu+value offset))))))
 724
 725       (_
 726        (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
 727        barf
 728        info)
 729       )))
 730
 731 (define (ident->constant name value)
 732   (cons name value))
 733
 734 (define (make-type name type size description)
 735   (cons name (list type size description)))
 736
 737 (define (enum->type name fields)
 738   (make-type name 'enum 4 fields))
 739
 740 (define (struct->type name fields)
 741   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
 742
 743 (define (decl->type o)
 744   (pmatch o
 745     ((fixed-type ,type) type)
 746     ((struct-ref (ident ,name)) (list "struct" name))
 747     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
 748      (list "struct" name)) ;; FIXME
 749     ((typename ,name) name)
 750     (_
 751      (stderr "SKIP: decl type=~s\n" o)
 752      barf
 753      o)))
 754
 755 (define (expr->global o)
 756   (pmatch o
 757     ((p-expr (string ,string)) (string->global string))
 758     (_ #f)))
 759
 760 (define (initzer->global o)
 761   (pmatch o
 762     ((initzer ,initzer) (expr->global initzer))
 763     (_ #f)))
 764
 765 (define (byte->hex o)
 766   (string->number (string-drop o 2) 16))
 767
 768 (define (asm->hex o)
 769   (let ((prefix ".byte "))
 770     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
 771         (let ((s (string-drop o (string-length prefix))))
 772           (map byte->hex (string-split s #\space))))))
 773
 774 (define (case->jump-info info)
 775   (define (jump n)
 776     (wrap-as (i386:Xjump n)))
 777   (define (jump-nz n)
 778     (wrap-as (i386:Xjump-nz n)))
 779   (define (statement->info info body-length)
 780     (lambda (o)
 781       (pmatch o
 782         ((break) (append-text info (jump body-length)))
 783         (_
 784          ((ast->info info) o)))))
 785   (lambda (o)
 786     (pmatch o
 787       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
 788        (lambda (body-length)
 789
 790          (define (test->text value clause-length)
 791            (append (wrap-as (i386:accu-cmp-value value))
 792                    (jump-nz clause-length)))
 793          (let* ((value (assoc-ref (.constants info) constant))
 794                 (test-info (append-text info (test->text value 0)))
 795                 (text-length (length (.text test-info)))
 796                 (clause-info (let loop ((elements elements) (info test-info))
 797                                (if (null? elements) info
 798                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
 799                 (clause-text (list-tail (.text clause-info) text-length))
 800                 (clause-length (length (text->list clause-text))))
 801            (clone info #:text (append
 802                                (.text info)
 803                                (test->text value clause-length)
 804                                clause-text)
 805                   #:globals (.globals clause-info)))))
 806
 807       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
 808        (lambda (body-length)
 809
 810          (define (test->text value clause-length)
 811            (append (wrap-as (i386:accu-cmp-value value))
 812                    (jump-nz clause-length)))
 813          (let* ((value (cstring->number value))
 814                 (test-info (append-text info (test->text value 0)))
 815                 (text-length (length (.text test-info)))
 816                 (clause-info (let loop ((elements elements) (info test-info))
 817                                (if (null? elements) info
 818                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
 819                 (clause-text (list-tail (.text clause-info) text-length))
 820                 (clause-length (length (text->list clause-text))))
 821            (clone info #:text (append
 822                                (.text info)
 823                                (test->text value clause-length)
 824                                clause-text)
 825                   #:globals (.globals clause-info)))))
 826
 827       ((case (neg (p-expr (fixed ,value))) ,statement)
 828        ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
 829
 830       ((default (compd-stmt (block-item-list . ,elements)))
 831        (lambda (body-length)
 832          (let ((text-length (length (.text info))))
 833            (let loop ((elements elements) (info info))
 834              (if (null? elements) info
 835                  (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
 836
 837       ((case (p-expr (ident ,constant)) ,statement)
 838        ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
 839
 840       ((case (p-expr (fixed ,value)) ,statement)
 841        ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
 842
 843       ((default ,statement)
 844        ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
 845
 846       (_ (stderr "no case match: ~a\n" o) barf)
 847       )))
 848
 849 (define (test->jump->info info)
 850   (define (jump type . test)
 851     (lambda (o)
 852       (let* ((text (.text info))
 853              (info (clone info #:text '()))
 854              (info ((ast->info info) o))
 855              (jump-text (lambda (body-length)
 856                           (wrap-as (type body-length)))))
 857         (lambda (body-length)
 858           (clone info #:text
 859                  (append text
 860                          (.text info)
 861                          (if (null? test) '() (car test))
 862                          (jump-text body-length)))))))
 863   (lambda (o)
 864     (pmatch o
 865       ;; unsigned
 866       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
 867       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
 868       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
 869       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
 870
 871       ((le ,a ,b) ((jump i386:Xjump-g) o))
 872       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
 873       ((ge ,a ,b) ((jump i386:Xjump-g) o))
 874       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
 875
 876       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
 877       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
 878       ((not _) ((jump i386:Xjump-z) o))
 879       ((and ,a ,b)
 880        (let* ((text (.text info))
 881               (info (clone info #:text '()))
 882
 883               (a-jump ((test->jump->info info) a))
 884               (a-text (.text (a-jump 0)))
 885               (a-length (length (text->list a-text)))
 886
 887               (b-jump ((test->jump->info info) b))
 888               (b-text (.text (b-jump 0)))
 889               (b-length (length (text->list b-text))))
 890
 891          (lambda (body-length)
 892            (clone info #:text
 893                   (append text
 894                           (.text (a-jump (+ b-length body-length)))
 895                           (.text (b-jump body-length)))))))
 896       ((or ,a ,b)
 897        (let* ((text (.text info))
 898               (info (clone info #:text '()))
 899
 900               (a-jump ((test->jump->info info) a))
 901               (a-text (.text (a-jump 0)))
 902               (a-length (length (text->list a-text)))
 903
 904               (jump-text (wrap-as (i386:Xjump 0)))
 905               (jump-length (length (text->list jump-text)))
 906
 907               (b-jump ((test->jump->info info) b))
 908               (b-text (.text (b-jump 0)))
 909               (b-length (length (text->list b-text)))
 910
 911               (jump-text (wrap-as (i386:Xjump b-length))))
 912
 913          (lambda (body-length)
 914            (clone info #:text
 915                   (append text
 916                           (.text (a-jump jump-length))
 917                           jump-text
 918                           (.text (b-jump body-length)))))))
 919
 920       ((array-ref . _) ((jump i386:jump-byte-z
 921                               (wrap-as (i386:accu-zero?))) o))
 922
 923       ((de-ref _) ((jump i386:jump-byte-z
 924                          (wrap-as (i386:accu-zero?))) o))
 925
 926       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
 927        ((jump i386:Xjump-z
 928               (append
 929                ((ident->accu info) name)
 930                (wrap-as (i386:accu-zero?)))) o))
 931
 932       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
 933
 934 (define (cstring->number s)
 935   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
 936         ((string-prefix? "0" s) (string->number s 8))
 937         (else (string->number s))))
 938
 939 (define (struct-field o)
 940   (pmatch o
 941     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
 942                 (comp-declr-list (comp-declr (ident ,name))))
 943      (cons type name))
 944     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
 945      (cons type name))
 946     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
 947      (cons type name))
 948     ((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)))))))))
 949      (cons type name)) ;; FIXME function / int
 950     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
 951      (cons type name)) ;; FIXME: ptr/char
 952     (_ (stderr "struct-field: no match: ~s\n" o) barf)))
 953
 954 (define (ast->type o)
 955   (pmatch o
 956     ((fixed-type ,type)
 957      type)
 958     ((struct-ref (ident ,type))
 959      (list "struct" type))
 960     (_ (stderr "SKIP: type=~s\n" o)
 961        "int")))
 962
 963 (define i386:type-alist
 964   '(("char" . (builtin 1 #f))
 965     ("int" . (builtin 4 #f))))
 966
 967 (define (type->size info o)
 968   ;;(stderr  "types=~s\n" (.types info))
 969   ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
 970   (pmatch o
 971     ((decl-spec-list (type-spec (fixed-type ,type)))
 972      (type->size info type))
 973     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
 974      (type->size info type))
 975     (_ (let ((type (assoc-ref (.types info) o)))
 976          (if type (cadr type)
 977              (begin
 978                (stderr "***TYPE NOT FOUND**: o=~s\n" o)
 979                barf
 980                4))))))
 981
 982 (define (ident->decl info o)
 983   ;; (stderr "ident->decl o=~s\n" o)
 984   ;; (stderr "  types=~s\n" (.types info))
 985   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
 986   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
 987   (or (assoc-ref (.locals info) o)
 988       (assoc-ref (.globals info) o)
 989       (begin
 990         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
 991         (assoc-ref (.functions info) o))))
 992
 993 (define (ident->type info o)
 994   (and=> (ident->decl info o) car))
 995
 996 (define (ident->pointer info o)
 997   (let ((local (assoc-ref (.locals info) o)))
 998     (if local (local:pointer local)
 999         (or (and=> (ident->decl info o) global:pointer) 0))))
1000
1001 (define (type->description info o)
1002   ;; (stderr  "type->description =~s\n" o)
1003   ;; (stderr  "types=~s\n" (.types info))
1004   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
1005   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
1006   (pmatch o
1007     ((decl-spec-list (type-spec (fixed-type ,type)))
1008      (type->description info type))
1009     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1010      (type->description info type))
1011     (_ (caddr (assoc-ref (.types info) o)))))
1012
1013 (define (local? o) ;; formals < 0, locals > 0
1014   (positive? (local:id o)))
1015
1016 (define (ast->info info)
1017   (lambda (o)
1018     (let ((globals (.globals info))
1019           (locals (.locals info))
1020           (constants (.constants info))
1021           (text (.text info)))
1022       (define (add-local locals name type pointer)
1023         (let* ((id (1+ (length (filter local? (map cdr locals)))))
1024                (locals (cons (make-local name type pointer id) locals)))
1025           locals))
1026
1027       ;; (stderr "\n ast->info=~s\n" o)
1028       ;; (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)))
1029       ;; (stderr "  text=~a\n" text)
1030       ;; (stderr "   info=~a\n" info)
1031       ;; (stderr "   globals=~a\n" globals)
1032       (pmatch o
1033         (((trans-unit . _) . _)
1034          ((ast-list->info info)  o))
1035         ((trans-unit . ,elements)
1036          ((ast-list->info info) elements))
1037         ((fctn-defn . _) ((function->info info) o))
1038         ((comment . _) info)
1039         ((cpp-stmt (define (name ,name) (repl ,value)))
1040          info)
1041
1042         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1043          info)
1044
1045         ;; FIXME: expr-stmt wrapper?
1046         (trans-unit info)
1047         ((expr-stmt) info)
1048
1049         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1050
1051         ((if ,test ,body)
1052          (let* ((text-length (length text))
1053
1054                 (test-jump->info ((test->jump->info info) test))
1055                 (test+jump-info (test-jump->info 0))
1056                 (test-length (length (.text test+jump-info)))
1057
1058                 (body-info ((ast->info test+jump-info) body))
1059                 (text-body-info (.text body-info))
1060                 (body-text (list-tail text-body-info test-length))
1061                 (body-length (length (text->list body-text)))
1062
1063                 (text+test-text (.text (test-jump->info body-length)))
1064                 (test-text (list-tail text+test-text text-length)))
1065
1066            (clone info #:text
1067                   (append text
1068                           test-text
1069                           body-text)
1070                   #:globals (.globals body-info))))
1071
1072         ((if ,test ,then ,else)
1073          (let* ((text-length (length text))
1074
1075                 (test-jump->info ((test->jump->info info) test))
1076                 (test+jump-info (test-jump->info 0))
1077                 (test-length (length (.text test+jump-info)))
1078
1079                 (then-info ((ast->info test+jump-info) then))
1080                 (text-then-info (.text then-info))
1081                 (then-text (list-tail text-then-info test-length))
1082                 (then-jump-text (wrap-as (i386:Xjump 0)))
1083                 (then-jump-length (length (text->list then-jump-text)))
1084                 (then-length (+ (length (text->list then-text)) then-jump-length))
1085
1086                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1087                 (else-info ((ast->info then+jump-info) else))
1088                 (text-else-info (.text else-info))
1089                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1090                 (else-length (length (text->list else-text)))
1091
1092                 (text+test-text (.text (test-jump->info then-length)))
1093                 (test-text (list-tail text+test-text text-length))
1094                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1095
1096            (clone info #:text
1097                   (append text
1098                           test-text
1099                           then-text
1100                           then-jump-text
1101                           else-text)
1102                   #:globals (append (.globals then-info)
1103                                     (list-tail (.globals else-info) (length globals))))))
1104
1105         ;; Hmm?
1106         ((expr-stmt (cond-expr ,test ,then ,else))
1107          (let* ((text-length (length text))
1108
1109                 (test-jump->info ((test->jump->info info) test))
1110                 (test+jump-info (test-jump->info 0))
1111                 (test-length (length (.text test+jump-info)))
1112
1113                 (then-info ((ast->info test+jump-info) then))
1114                 (text-then-info (.text then-info))
1115                 (then-text (list-tail text-then-info test-length))
1116                 (then-length (length (text->list then-text)))
1117
1118                 (jump-text (wrap-as (i386:Xjump 0)))
1119                 (jump-length (length (text->list jump-text)))
1120
1121                 (test+then+jump-info
1122                  (clone then-info
1123                         #:text (append (.text then-info) jump-text)))
1124
1125                 (else-info ((ast->info test+then+jump-info) else))
1126                 (text-else-info (.text else-info))
1127                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1128                 (else-length (length (text->list else-text)))
1129
1130                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1131                 (test-text (list-tail text+test-text text-length))
1132                 (jump-text (wrap-as (i386:Xjump else-length))))
1133
1134            (clone info #:text
1135                   (append text
1136                           test-text
1137                           then-text
1138                           jump-text
1139                           else-text)
1140                   #:globals (.globals else-info))))
1141
1142         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1143          (let* ((expr ((expr->accu info) expr))
1144                 (empty (clone info #:text '()))
1145                 (case-infos (map (case->jump-info empty) cases))
1146                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1147                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1148                               (if (null? cases) info
1149                                   (let ((c-j ((case->jump-info info) (car cases))))
1150                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1151            cases-info))
1152
1153         ((for ,init ,test ,step ,body)
1154          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1155
1156                 (info ((ast->info info) init))
1157
1158                 (init-text (.text info))
1159                 (init-locals (.locals info))
1160                 (info (clone info #:text '()))
1161
1162                 (body-info ((ast->info info) body))
1163                 (body-text (.text body-info))
1164                 (body-length (length (text->list body-text)))
1165
1166                 (step-info ((expr->accu info) step))
1167                 (step-text (.text step-info))
1168                 (step-length (length (text->list step-text)))
1169
1170                 (test-jump->info ((test->jump->info info) test))
1171                 (test+jump-info (test-jump->info 0))
1172                 (test-length (length (text->list (.text test+jump-info))))
1173
1174                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1175
1176                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1177                 (jump-length (length (text->list jump-text)))
1178
1179                 (test-text (.text (test-jump->info jump-length))))
1180
1181            (clone info #:text
1182                   (append text
1183                           init-text
1184                           skip-body-text
1185                           body-text
1186                           step-text
1187                           test-text
1188                           jump-text)
1189                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1190                   #:locals locals)))
1191
1192         ;; FIXME: support break statement (see switch/case)
1193         ((while ,test ,body)
1194          (let* ((skip-info (lambda (body-length)
1195                              (clone info #:text (append text
1196                                                         (wrap-as (i386:Xjump body-length))))))
1197                 (text (.text (skip-info 0)))
1198                 (text-length (length text))
1199
1200                 (body-info (lambda (body-length)
1201                              ((ast->info (skip-info body-length)) body)))
1202                 (body-text (list-tail (.text (body-info 0)) text-length))
1203                 (body-length (length (text->list body-text)))
1204
1205                 (body-info (body-info body-length))
1206
1207                 (empty (clone info #:text '()))
1208                 (test-jump->info ((test->jump->info empty) test))
1209                 (test+jump-info (test-jump->info 0))
1210                 (test-length (length (text->list (.text test+jump-info))))
1211
1212                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1213                 (jump-length (length (text->list jump-text)))
1214
1215                 (test-text (.text (test-jump->info jump-length))))
1216            (clone info #:text
1217                   (append
1218                    (.text body-info)
1219                    test-text
1220                    jump-text)
1221                   #:globals (.globals body-info))))
1222
1223         ((do-while ,body ,test)
1224          (let* ((text-length (length text))
1225
1226                 (body-info ((ast->info info) body))
1227                 (body-text (list-tail (.text body-info) text-length))
1228                 (body-length (length (text->list body-text)))
1229
1230                 (empty (clone info #:text '()))
1231                 (test-jump->info ((test->jump->info empty) test))
1232                 (test+jump-info (test-jump->info 0))
1233                 (test-length (length (text->list (.text test+jump-info))))
1234
1235                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1236                 (jump-length (length (text->list jump-text)))
1237
1238                 (test-text (.text (test-jump->info jump-length))))
1239            (clone info #:text
1240                   (append
1241                    (.text body-info)
1242                    test-text
1243                    jump-text)
1244                   #:globals (.globals body-info))))
1245
1246         ((labeled-stmt (ident ,label) ,statement)
1247          (let ((info (append-text info (list label))))
1248            ((ast->info info) statement)))
1249
1250         ((goto (ident ,label))
1251          (let* ((jump (lambda (n) (i386:XXjump n)))
1252                 (offset (+ (length (jump 0)) (length (text->list text)))))
1253            (append-text info (append
1254                               (list (lambda (f g ta t d)
1255                                       (jump (- (label-offset (.function info) label f) offset))))))))
1256
1257         ((return ,expr)
1258          (let ((info ((expr->accu info) expr)))
1259            (append-text info (append  (wrap-as (i386:ret))))))
1260
1261         ;; DECL
1262
1263         ;; int i;
1264         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1265          (if (.function info)
1266              (clone info #:locals (add-local locals name type 0))
1267              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1268
1269         ;; int i = 0;
1270         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1271          (let ((value (cstring->number value)))
1272            (if (.function info)
1273                (let* ((locals (add-local locals name type 0))
1274                       (info (clone info #:locals locals)))
1275                  (append-text info ((value->ident info) name value)))
1276                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1277
1278         ;; char c = 'A';
1279         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1280          (if (not (.function info)) decl-barf0)
1281          (let* ((locals (add-local locals name type 0))
1282                 (info (clone info #:locals locals))
1283                 (value (char->integer (car (string->list value)))))
1284            (append-text info ((value->ident info) name value))))
1285
1286         ;; int i = -1;
1287         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1288          (let ((value (- (cstring->number value))))
1289            (if (.function info)
1290                (let* ((locals (add-local locals name type 0))
1291                       (info (clone info #:locals locals)))
1292                  (append-text info ((value->ident info) name value)))
1293                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1294
1295         ;; int i = argc;
1296         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1297          (if (not (.function info)) decl-barf2)
1298          (let* ((locals (add-local locals name type 0))
1299                 (info (clone info #:locals locals)))
1300            (append-text info (append ((ident->accu info) local)
1301                                      ((accu->ident info) name)))))
1302
1303         ;; char *p = "t.c";
1304         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1305          (when (not (.function info))
1306            (stderr "o=~s\n" o)
1307            decl-barf3)
1308          (let* ((locals (add-local locals name type 1))
1309                 (globals (append globals (list (string->global string))))
1310                 (info (clone info #:locals locals #:globals globals)))
1311            (append-text info (append
1312                               (list (lambda (f g ta t d)
1313                                       (append
1314                                        (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1315                               ((accu->ident info) name)))))
1316
1317         ;; char *p = 0;
1318         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1319          (let ((value (cstring->number value)))
1320            (if (.function info)
1321                (let* ((locals (add-local locals name type 1))
1322                       (info (clone info #:locals locals)))
1323                  (append-text info (append (wrap-as (i386:value->accu value))
1324                                            ((accu->ident info) name))))
1325                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1326
1327         ;; char arena[20000];
1328         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1329          (let ((type (ast->type type)))
1330            (if (.function info)
1331                TODO:decl-array
1332                (let* ((globals (.globals info))
1333                       (count (cstring->number count))
1334                       (size (type->size info type))
1335                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1336                       (globals (append globals (list array))))
1337                  (clone info #:globals globals)))))
1338
1339         ;;struct scm *g_cells = (struct scm*)arena;
1340         ((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)))))))
1341          ;;(stderr "0TYPE: ~s\n" type)
1342          (if (.function info)
1343              (let* ((locals (add-local locals name type 1))
1344                     (info (clone info #:locals locals)))
1345                (append-text info (append ((ident->accu info) name)
1346                                          ((accu->ident info) value)))) ;; FIXME: deref?
1347              (let* ((globals (append globals (list (ident->global name type 1 0))))
1348                     (info (clone info #:globals globals)))
1349                (append-text info (append ((ident->accu info) name)
1350                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1351
1352         ;; SCM tmp;
1353         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1354          ;;(stderr  "1TYPE: ~s\n" type)
1355          (if (.function info)
1356              (clone info #:locals (add-local locals name type 0))
1357              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1358
1359         ;; SCM g_stack = 0;
1360         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1361          ;;(stderr  "2TYPE: ~s\n" type)
1362          (let ((value (cstring->number value)))
1363            (if (.function info)
1364                (let* ((locals (add-local locals name type 0))
1365                       (info (clone info #:locals locals)))
1366                  (append-text info ((value->ident info) name value)))
1367                (let ((globals (append globals (list (ident->global name type 0 value)))))
1368                  (clone info #:globals globals)))))
1369
1370         ;; SCM g_stack = 0; // comment
1371         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1372          ((ast->info info) (list-head o (- (length o) 1))))
1373
1374         ;; SCM i = argc;
1375         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1376          ;;(stderr  "3TYPE: ~s\n" type)
1377          (if (.function info)
1378              (let* ((locals (add-local locals name type 0))
1379                     (info (clone info #:locals locals)))
1380                (append-text info (append ((ident->accu info) local)
1381                                          ((accu->ident info) name))))
1382              (let* ((globals (append globals (list (ident->global name type 0 0))))
1383                     (info (clone info #:globals globals)))
1384                (append-text info (append ((ident->accu info) local)
1385                                          ((accu->ident info) name))))))
1386
1387         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1388         ((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))))
1389          (let* ((locals (add-local locals name type 1))
1390                 (info (clone info #:locals locals))
1391                 (empty (clone info #:text '()))
1392                 (accu ((expr->accu empty) initzer)))
1393            (clone info
1394                   #:text
1395                   (append text
1396                           (.text accu)
1397                           ((accu->ident info) name)
1398                           (list (lambda (f g ta t d)
1399                                   (append (i386:value->base ta)
1400                                           (i386:accu+base)))))
1401                   #:locals locals)))
1402
1403         ;; char *p = (char*)g_cells;
1404         ((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)))))))
1405          ;;(stderr  "6TYPE: ~s\n" type)
1406          (if (.function info)
1407              (let* ((locals (add-local locals name type 1))
1408                     (info (clone info #:locals locals)))
1409                (append-text info (append ((ident->accu info) value)
1410                                          ((accu->ident info) name))))
1411              (let* ((globals (append globals (list (ident->global name type 1 0))))
1412                     (here (data-offset name globals))
1413                     (there (data-offset value globals)))
1414                (clone info
1415                       #:globals globals
1416                       #:init (append (.init info)
1417                                      (list (lambda (functions globals ta t d data)
1418                                              (append
1419                                               (list-head data here)
1420                                               ;;; FIXME: type
1421                                               ;;; char *x = arena;
1422                                               (int->bv32 (+ d (data-offset value globals)))
1423                                               ;;; char *y = x;
1424                                               ;;;(list-head (list-tail data there) 4)
1425                                               (list-tail data (+ here 4))))))))))
1426
1427         ;; char *p = g_cells;
1428         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1429          ;;(stderr  "7TYPE: ~s\n" type)
1430          (let ((type (decl->type type)))
1431            ;;(stderr "0DECL: ~s\n" type)
1432            (if (.function info)
1433                (let* ((locals (add-local locals name type  1))
1434                       (info (clone info #:locals locals)))
1435                  (append-text info (append ((ident->accu info) value)
1436                                            ((accu->ident info) name))))
1437                (let* ((globals (append globals (list (ident->global name type 1 0))))
1438                       (here (data-offset name globals)))
1439                  (clone info
1440                         #:globals globals
1441                         #:init (append (.init info)
1442                                        (list (lambda (functions globals ta t d data)
1443                                                (append
1444                                                 (list-head data here)
1445                                               ;;; FIXME: type
1446                                               ;;; char *x = arena;p
1447                                                 (int->bv32 (+ d (data-offset value globals)))
1448                                                 (list-tail data (+ here 4)))))))))))
1449
1450         ;; enum
1451         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1452          (let ((type (enum->type name fields))
1453                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1454            (clone info
1455                   #:types (append (.types info) (list type))
1456                   #:constants (append constants (.constants info)))))
1457
1458         ;; struct
1459         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1460          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1461            ;;(stderr "type: ~a\n" type)
1462            (clone info #:types (append (.types info) (list type)))))
1463
1464         ;; DECL
1465         ;;
1466         ;; struct f = {...};
1467         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1468          (let* ((type (decl->type type))
1469                 ;;(foo (stderr "1DECL: ~s\n" type))
1470                 (fields (type->description info type))
1471                 (size (type->size info type))
1472                 (field-size 4))  ;; FIXME:4, not fixed
1473            ;;(stderr  "7TYPE: ~s\n" type)
1474            (if (.function info)
1475                (let* ((globals (append globals (filter-map initzer->global initzers)))
1476                       (locals (let loop ((fields (cdr fields)) (locals locals))
1477                                 (if (null? fields) locals
1478                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1479                       (locals (add-local locals name type -1))
1480                       (info (clone info #:locals locals #:globals globals))
1481                       (empty (clone info #:text '())))
1482                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1483                    (if (null? fields) info
1484                        (let ((offset (* field-size (car fields)))
1485                              (initzer (car initzers)))
1486                          (loop (cdr fields) (cdr initzers)
1487                                (clone info #:text
1488                                       (append
1489                                        (.text info)
1490                                        ((ident->accu info) name)
1491                                        (wrap-as (append (i386:accu->base)))
1492                                        (.text ((expr->accu empty) initzer))
1493                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1494                (let* ((globals (append globals (filter-map initzer->global initzers)))
1495                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1496                       (globals (append globals (list global)))
1497                       (here (data-offset name globals))
1498                       (info (clone info #:globals globals))
1499                       (field-size 4))
1500                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1501                    (if (null? fields) info
1502                        (let ((offset (* field-size (car fields)))
1503                              (initzer (car initzers)))
1504                          (loop (cdr fields) (cdr initzers)
1505                                (clone info #:init
1506                                       (append
1507                                        (.init info)
1508                                        (list (lambda (functions globals ta t d data)
1509                                                (append
1510                                                 (list-head data (+ here offset))
1511                                                 (initzer->data info functions globals ta t d (car initzers))
1512                                                 (list-tail data (+ here offset field-size)))))))))))))))
1513
1514
1515         ;;char cc = g_cells[c].cdr;  ==> generic?
1516         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1517          (let ((type (decl->type type)))
1518            (if (.function info)
1519                (let* ((locals (add-local locals name type 0))
1520                       (info (clone info #:locals locals)))
1521                  (clone info #:text
1522                         (append (.text ((expr->accu info) initzer))
1523                                 ((accu->ident info) name))))
1524                (let* ((globals (append globals (list (ident->global name type 1 0))))
1525                       (here (data-offset name globals)))
1526                  (clone info
1527                         #:globals globals
1528                         #:init (append (.init info)
1529                                        (list (lambda (functions globals ta t d data)
1530                                                (append
1531                                                 (list-head data here)
1532                                                 (initzer->data info functions globals ta t d initzer)
1533                                                 (list-tail data (+ here 4)))))))))))
1534
1535
1536         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1537          info)
1538
1539         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1540          info)
1541
1542         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1543          (let ((types (.types info)))
1544            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1545
1546         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1547          (format (current-error-port) "SKIP: typedef=~s\n" o)
1548          info)
1549
1550         ((decl (@ ,at))
1551          (format (current-error-port) "SKIP: at=~s\n" o)
1552          info)
1553
1554         ((decl . _)
1555          (format (current-error-port) "SKIP: decl statement=~s\n" o)
1556          barf
1557          info)
1558
1559         ;; ...
1560         ((gt . _) ((expr->accu info) o))
1561         ((ge . _) ((expr->accu info) o))
1562         ((ne . _) ((expr->accu info) o))
1563         ((eq . _) ((expr->accu info) o))
1564         ((le . _) ((expr->accu info) o))
1565         ((lt . _) ((expr->accu info) o))
1566         ((lshift . _) ((expr->accu info) o))
1567         ((rshift . _) ((expr->accu info) o))
1568
1569         ;; EXPR
1570         ((expr-stmt ,expression)
1571          (let ((info ((expr->accu info) expression)))
1572            (append-text info (wrap-as (i386:accu-zero?)))))
1573
1574         ;; FIXME: why do we get (post-inc ...) here
1575         ;; (array-ref
1576         (_ (let ((info ((expr->accu info) o)))
1577              (append-text info (wrap-as (i386:accu-zero?)))))))))
1578
1579 (define (initzer->data info functions globals ta t d o)
1580   (pmatch o
1581     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1582     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1583     ((initzer (ref-to (p-expr (ident ,name))))
1584      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
1585      (int->bv32 (+ ta (function-offset name functions))))
1586     ((initzer (p-expr (ident ,name)))
1587      (let ((value (assoc-ref (.constants info) name)))
1588        (int->bv32 value)))
1589     ((initzer (p-expr (string ,string)))
1590      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
1591     (_ (stderr "initzer->data:SKIP: ~s\n" o)
1592        barf
1593        (int->bv32 0))))
1594
1595 (define (info->exe info)
1596   (display "dumping elf\n" (current-error-port))
1597   (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
1598
1599 (define (.formals o)
1600   (pmatch o
1601     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1602     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1603     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
1604        barf)))
1605
1606 (define (formal->text n)
1607   (lambda (o i)
1608     ;;(i386:formal i n)
1609     '()
1610     ))
1611
1612 (define (formals->text o)
1613   (pmatch o
1614     ((param-list . ,formals)
1615      (let ((n (length formals)))
1616        (wrap-as (append (i386:function-preamble)
1617                         (append-map (formal->text n) formals (iota n))
1618                         (i386:function-locals)))))
1619     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
1620        barf)))
1621
1622 (define (formal:ptr o)
1623   (pmatch o
1624     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1625      1)
1626     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
1627      0)
1628     (_
1629      (stderr "formal:ptr[~a] => 0\n" o)
1630      0)))
1631
1632 (define (formals->locals o)
1633   (pmatch o
1634     ((param-list . ,formals)
1635      (let ((n (length formals)))
1636        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
1637     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
1638        barf)))
1639
1640 (define (function->info info)
1641   (lambda (o)
1642     ;;(stderr "function->info o=~s\n" o)
1643     ;;(stderr "formals=~s\n" (.formals o))
1644     (let* ((name (.name o))
1645            (formals (.formals o))
1646            (text (formals->text formals))
1647            (locals (formals->locals formals)))
1648       (format (current-error-port) "compiling ~s\n" name)
1649       ;;(stderr "locals=~s\n" locals)
1650       (let loop ((statements (.statements o))
1651                  (info (clone info #:locals locals #:function (.name o) #:text text)))
1652         (if (null? statements) (clone info
1653                                       #:function #f
1654                                       #:functions (append (.functions info) (list (cons name (.text info)))))
1655             (let* ((statement (car statements)))
1656               (loop (cdr statements)
1657                     ((ast->info info) (car statements)))))))))
1658
1659 (define (ast-list->info info)
1660   (lambda (elements)
1661     (let loop ((elements elements) (info info))
1662       (if (null? elements) info
1663           (loop (cdr elements) ((ast->info info) (car elements)))))))
1664
1665 (define (compile)
1666   (stderr "COMPILE\n")
1667   (let* ((ast (mescc))
1668          (info (make <info>
1669                  #:functions i386:libc
1670                  #:types i386:type-alist))
1671          (ast (append libc ast))
1672          (info ((ast->info info) ast))
1673          (info ((ast->info info) _start)))
1674     (info->exe info)))