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