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 (case->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 (ast->info info)
1096   (lambda (o)
1097     (let ((globals (.globals info))
1098           (locals (.locals info))
1099           (constants (.constants info))
1100           (text (.text info)))
1101       (define (add-local locals name type pointer)
1102         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1103                        (1+ (local:id (cdar locals)))))
1104                (locals (cons (make-local name type pointer id) locals)))
1105           locals))
1106
1107       (pmatch o
1108         (((trans-unit . _) . _)
1109          ((ast-list->info info)  o))
1110         ((trans-unit . ,elements)
1111          ((ast-list->info info) elements))
1112         ((fctn-defn . _) ((function->info info) o))
1113         ((comment . _) info)
1114         ((cpp-stmt (define (name ,name) (repl ,value)))
1115          info)
1116
1117         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1118          info)
1119
1120         ((break)
1121          (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (text->list text)))))))
1122
1123         ;; FIXME: expr-stmt wrapper?
1124         (trans-unit info)
1125         ((expr-stmt) info)
1126
1127         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1128
1129         ((if ,test ,body)
1130          (let* ((text-length (length text))
1131
1132                 (test-jump->info ((test->jump->info info) test))
1133                 (test+jump-info (test-jump->info 0))
1134                 (test-length (length (.text test+jump-info)))
1135
1136                 (body-info ((ast->info test+jump-info) body))
1137                 (text-body-info (.text body-info))
1138                 (body-text (list-tail text-body-info test-length))
1139                 (body-length (length (text->list body-text)))
1140
1141                 (text+test-text (.text (test-jump->info body-length)))
1142                 (test-text (list-tail text+test-text text-length)))
1143
1144            (clone info #:text
1145                   (append text
1146                           test-text
1147                           body-text)
1148                   #:globals (.globals body-info))))
1149
1150         ((if ,test ,then ,else)
1151          (let* ((text-length (length text))
1152
1153                 (test-jump->info ((test->jump->info info) test))
1154                 (test+jump-info (test-jump->info 0))
1155                 (test-length (length (.text test+jump-info)))
1156
1157                 (then-info ((ast->info test+jump-info) then))
1158                 (text-then-info (.text then-info))
1159                 (then-text (list-tail text-then-info test-length))
1160                 (then-jump-text (wrap-as (i386:Xjump 0)))
1161                 (then-jump-length (length (text->list then-jump-text)))
1162                 (then-length (+ (length (text->list then-text)) then-jump-length))
1163
1164                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1165                 (else-info ((ast->info then+jump-info) else))
1166                 (text-else-info (.text else-info))
1167                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1168                 (else-length (length (text->list else-text)))
1169
1170                 (text+test-text (.text (test-jump->info then-length)))
1171                 (test-text (list-tail text+test-text text-length))
1172                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1173
1174            (clone info #:text
1175                   (append text
1176                           test-text
1177                           then-text
1178                           then-jump-text
1179                           else-text)
1180                   #:globals (append (.globals then-info)
1181                                     (list-tail (.globals else-info) (length globals))))))
1182
1183         ;; Hmm?
1184         ((expr-stmt (cond-expr ,test ,then ,else))
1185          (let* ((text-length (length text))
1186
1187                 (test-jump->info ((test->jump->info info) test))
1188                 (test+jump-info (test-jump->info 0))
1189                 (test-length (length (.text test+jump-info)))
1190
1191                 (then-info ((ast->info test+jump-info) then))
1192                 (text-then-info (.text then-info))
1193                 (then-text (list-tail text-then-info test-length))
1194                 (then-length (length (text->list then-text)))
1195
1196                 (jump-text (wrap-as (i386:Xjump 0)))
1197                 (jump-length (length (text->list jump-text)))
1198
1199                 (test+then+jump-info
1200                  (clone then-info
1201                         #:text (append (.text then-info) jump-text)))
1202
1203                 (else-info ((ast->info test+then+jump-info) else))
1204                 (text-else-info (.text else-info))
1205                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1206                 (else-length (length (text->list else-text)))
1207
1208                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1209                 (test-text (list-tail text+test-text text-length))
1210                 (jump-text (wrap-as (i386:Xjump else-length))))
1211
1212            (clone info #:text
1213                   (append text
1214                           test-text
1215                           then-text
1216                           jump-text
1217                           else-text)
1218                   #:globals (.globals else-info))))
1219
1220         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1221          (let* ((expr ((expr->accu info) expr))
1222                 (empty (clone info #:text '()))
1223                 (case-infos (map (case->jump-info empty) cases))
1224                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1225                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1226                               (if (null? cases) info
1227                                   (let ((c-j ((case->jump-info info) (car cases))))
1228                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1229            cases-info))
1230
1231         ((for ,init ,test ,step ,body)
1232          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1233
1234                 (info ((ast->info info) init))
1235
1236                 (init-text (.text info))
1237                 (init-locals (.locals info))
1238                 (info (clone info #:text '()))
1239
1240                 (body-info ((ast->info info) body))
1241                 (body-text (.text body-info))
1242                 (body-length (length (text->list body-text)))
1243
1244                 (step-info ((expr->accu info) step))
1245                 (step-text (.text step-info))
1246                 (step-length (length (text->list step-text)))
1247
1248                 (test-jump->info ((test->jump->info info) test))
1249                 (test+jump-info (test-jump->info 0))
1250                 (test-length (length (text->list (.text test+jump-info))))
1251
1252                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1253
1254                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1255                 (jump-length (length (text->list jump-text)))
1256
1257                 (test-text (.text (test-jump->info jump-length))))
1258
1259            (clone info #:text
1260                   (append text
1261                           init-text
1262                           skip-body-text
1263                           body-text
1264                           step-text
1265                           test-text
1266                           jump-text)
1267                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1268                   #:locals locals)))
1269
1270         ((while ,test ,body)
1271          (let* ((skip-info (lambda (body-length test-length)
1272                              (clone info
1273                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1274                                     #:break (cons (+ (length (text->list text)) body-length test-length
1275                                                      (length (i386:Xjump 0)))
1276                                                   (.break info)))))
1277                 (text (.text (skip-info 0 0)))
1278                 (text-length (length text))
1279                 (body-info (lambda (body-length test-length)
1280                              ((ast->info (skip-info body-length test-length)) body)))
1281
1282                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1283                 (body-length (length (text->list body-text)))
1284
1285                 (empty (clone info #:text '()))
1286                 (test-jump->info ((test->jump->info empty) test))
1287                 (test+jump-info (test-jump->info 0))
1288                 (test-length (length (text->list (.text test+jump-info))))
1289
1290                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1291                 (jump-length (length (text->list jump-text)))
1292
1293                 (test-text (.text (test-jump->info jump-length)))
1294
1295                 (body-info (body-info body-length (length (text->list test-text)))))
1296
1297            (clone info #:text
1298                   (append
1299                    (.text body-info)
1300                    test-text
1301                    jump-text)
1302                   #:globals (.globals body-info))))
1303
1304         ((do-while ,body ,test)
1305          (let* ((text-length (length text))
1306
1307                 (body-info ((ast->info info) body))
1308                 (body-text (list-tail (.text body-info) text-length))
1309                 (body-length (length (text->list body-text)))
1310
1311                 (empty (clone info #:text '()))
1312                 (test-jump->info ((test->jump->info empty) test))
1313                 (test+jump-info (test-jump->info 0))
1314                 (test-length (length (text->list (.text test+jump-info))))
1315
1316                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1317                 (jump-length (length (text->list jump-text)))
1318
1319                 (test-text (.text (test-jump->info jump-length))))
1320            (clone info #:text
1321                   (append
1322                    (.text body-info)
1323                    test-text
1324                    jump-text)
1325                   #:globals (.globals body-info))))
1326
1327         ((labeled-stmt (ident ,label) ,statement)
1328          (let ((info (append-text info (list label))))
1329            ((ast->info info) statement)))
1330
1331         ((goto (ident ,label))
1332          (let* ((jump (lambda (n) (i386:XXjump n)))
1333                 (offset (+ (length (jump 0)) (length (text->list text)))))
1334            (append-text info (append
1335                               (list (lambda (f g ta t d)
1336                                       (jump (- (label-offset (.function info) label f) offset))))))))
1337
1338         ((return ,expr)
1339          (let ((info ((expr->accu info) expr)))
1340            (append-text info (append  (wrap-as (i386:ret))))))
1341
1342         ;; DECL
1343
1344         ;; int i;
1345         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1346          (if (.function info)
1347              (clone info #:locals (add-local locals name type 0))
1348              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1349
1350         ;; int i = 0;
1351         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1352          (let ((value (cstring->number value)))
1353            (if (.function info)
1354                (let* ((locals (add-local locals name type 0))
1355                       (info (clone info #:locals locals)))
1356                  (append-text info ((value->ident info) name value)))
1357                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1358
1359         ;; char c = 'A';
1360         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1361          (if (not (.function info)) (error "ast->info: unsupported: " o))
1362          (let* ((locals (add-local locals name type 0))
1363                 (info (clone info #:locals locals))
1364                 (value (char->integer (car (string->list value)))))
1365            (append-text info ((value->ident info) name value))))
1366
1367         ;; int i = -1;
1368         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1369          (let ((value (- (cstring->number value))))
1370            (if (.function info)
1371                (let* ((locals (add-local locals name type 0))
1372                       (info (clone info #:locals locals)))
1373                  (append-text info ((value->ident info) name value)))
1374                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1375
1376         ;; int i = argc;
1377         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1378          (if (not (.function info)) (error "ast->info: unsupported: " o))
1379          (let* ((locals (add-local locals name type 0))
1380                 (info (clone info #:locals locals)))
1381            (append-text info (append ((ident->accu info) local)
1382                                      ((accu->ident info) name)))))
1383
1384         ;; char *p = "foo";
1385         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1386          (if (.function info)
1387              (let* ((locals (add-local locals name type 1))
1388                     (globals (append globals (list (string->global string))))
1389                     (info (clone info #:locals locals #:globals globals)))
1390                (append-text info (append
1391                                   (list (lambda (f g ta t d)
1392                                           (append
1393                                            (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1394                                   ((accu->ident info) name))))
1395              (let* ((global (string->global string))
1396                     (globals (append globals (list global)))
1397                     (size 4)
1398                     (global (make-global name type 1 (string->list (make-string size #\nul))))
1399                     (globals (append globals (list global)))
1400                     (info (clone info #:globals globals))
1401                     (here (data-offset name globals)))
1402                (clone info #:init
1403                       (append
1404                        (.init info)
1405                        (list (lambda (functions globals ta t d data)
1406                                (append
1407                                 (list-head data here)
1408                                 (initzer->data info functions globals ta t d `(initzer (p-expr (string ,string))))
1409                                 (list-tail data (+ here size))))))))))
1410
1411         ;; char const *p;
1412         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1413          (if (.function info)
1414              (let* ((locals (add-local locals name type 1))
1415                     (info (clone info #:locals locals)))
1416                (append-text info (append (wrap-as (i386:value->accu 0))
1417                                          ((accu->ident info) name))))
1418              (let ((globals (append globals (list (ident->global name type 1 0)))))
1419                (clone info #:globals globals))))
1420
1421         ;; char *p;
1422         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1423          (if (.function info)
1424              (let* ((locals (add-local locals name type 1))
1425                     (info (clone info #:locals locals)))
1426                (append-text info (append (wrap-as (i386:value->accu 0))
1427                                          ((accu->ident info) name))))
1428              (let ((globals (append globals (list (ident->global name type 1 0)))))
1429                (clone info #:globals globals))))
1430
1431         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1432          (let ((value (cstring->number value)))
1433            (if (.function info)
1434                (let* ((locals (add-local locals name type 1))
1435                       (info (clone info #:locals locals)))
1436                  (append-text info (append (wrap-as (i386:value->accu value))
1437                                            ((accu->ident info) name))))
1438                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1439
1440         ;; char **p;
1441         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1442          (if (.function info)
1443              (let* ((locals (add-local locals name type 2))
1444                     (info (clone info #:locals locals)))
1445                (append-text info (append (wrap-as (i386:value->accu 0))
1446                                          ((accu->ident info) name))))
1447              (let ((globals (append globals (list (ident->global name type 2 0)))))
1448                (clone info #:globals globals))))
1449
1450         ;; char **p = 0;
1451         ;;((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)))))))
1452
1453         ;; char **p = g_environment;
1454         ((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
1455          (if (.function info)
1456              (let* ((locals (add-local locals name type 2))
1457                     (info (clone info #:locals locals)))
1458                (append-text info (append
1459                                   ((ident->accu info) b)
1460                                   ((accu->ident info) name))))
1461              (let* ((globals (append globals (list (ident->global name type 2 0))))
1462                     (here (data-offset name globals)))
1463                (clone info
1464                       #:globals globals
1465                       #:init (append (.init info)
1466                                      (list (lambda (functions globals ta t d data)
1467                                              (append
1468                                               (list-head data here)
1469                                               ;;(initzer->data info functions globals ta t d initzer)
1470                                               (initzer->data info functions globals ta t d `(p-expr (ident ,b)))
1471                                               (list-tail data (+ here 4))))))))
1472              ;;;(clone info #:globals (append globals (list (ident->global name type 1 0))))
1473              ))
1474
1475         ;; struct foo bar[2];
1476         ;; char arena[20000];
1477         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1478          (let ((type (ast->type type)))
1479            (if (.function info)
1480                (let* ((local (car (add-local locals name type -1)))
1481                       (count (string->number count))
1482                       (size (type->size info type))
1483                       (local (make-local name type -1 (+ (local:id local) (* count size))))
1484                       (locals (cons local locals))
1485                       (info (clone info #:locals locals)))
1486                  info)
1487                (let* ((globals (.globals info))
1488                       (count (cstring->number count))
1489                       (size (type->size info type))
1490                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1491                       (globals (append globals (list array))))
1492                  (clone info #:globals globals)))))
1493
1494         ;; char* a[10];
1495         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1496          (let ((type (ast->type type)))
1497            (if (.function info)
1498                (let* ((local (car (add-local locals name type -1)))
1499                       (count (string->number count))
1500                       (size (type->size info type))
1501                       (local (make-local name type 1 (+ (local:id local) (* count size))))
1502                       (locals (cons local locals))
1503                       (info (clone info #:locals locals)))
1504                  info)
1505                (let* ((globals (.globals info))
1506                       (count (cstring->number count))
1507                       (size (type->size info type))
1508                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1509                       (globals (append globals (list array))))
1510                  (clone info #:globals globals)))))
1511
1512         ;; struct foo bar;
1513         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1514          (if (.function info)
1515              (let* ((locals (add-local locals name `("struct" ,type) 1))
1516                     (info (clone info #:locals locals)))
1517                info)
1518              (let* ((size (type->size info (list "struct" type)))
1519                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1520                     (globals (append globals (list global)))
1521                     (info (clone info #:globals globals)))
1522                info)))
1523
1524         ;;struct scm *g_cells = (struct scm*)arena;
1525         ((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)))))))
1526          (if (.function info)
1527              (let* ((locals (add-local locals name `("struct" ,type) 1))
1528                     (info (clone info #:locals locals)))
1529                (append-text info (append ((ident->accu info) name)
1530                                          ((accu->ident info) value)))) ;; FIXME: deref?
1531              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1532                     (info (clone info #:globals globals)))
1533                (append-text info (append ((ident->accu info) name)
1534                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1535
1536
1537         ;; SCM tmp;
1538         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1539          (if (.function info)
1540              (clone info #:locals (add-local locals name type 0))
1541              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1542
1543         ;; SCM g_stack = 0;
1544         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1545          (let ((value (cstring->number value)))
1546            (if (.function info)
1547                (let* ((locals (add-local locals name type 0))
1548                       (info (clone info #:locals locals)))
1549                  (append-text info ((value->ident info) name value)))
1550                (let ((globals (append globals (list (ident->global name type 0 value)))))
1551                  (clone info #:globals globals)))))
1552
1553         ;; SCM g_stack = 0; // comment
1554         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1555          ((ast->info info) (list-head o (- (length o) 1))))
1556
1557         ;; SCM i = argc;
1558         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1559          (if (.function info)
1560              (let* ((locals (add-local locals name type 0))
1561                     (info (clone info #:locals locals)))
1562                (append-text info (append ((ident->accu info) local)
1563                                          ((accu->ident info) name))))
1564              (let* ((globals (append globals (list (ident->global name type 0 0))))
1565                     (info (clone info #:globals globals)))
1566                (append-text info (append ((ident->accu info) local)
1567                                          ((accu->ident info) name))))))
1568
1569         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1570         ((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))))
1571          (let* ((locals (add-local locals name type 1))
1572                 (info (clone info #:locals locals))
1573                 (empty (clone info #:text '()))
1574                 (accu ((expr->accu empty) initzer)))
1575            (clone info
1576                   #:text
1577                   (append text
1578                           (.text accu)
1579                           ((accu->ident info) name)
1580                           (list (lambda (f g ta t d)
1581                                   (append (i386:value->base ta)
1582                                           (i386:accu+base)))))
1583                   #:locals locals)))
1584
1585         ;; char *p = (char*)g_cells;
1586         ((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)))))))
1587          (if (.function info)
1588              (let* ((locals (add-local locals name type 1))
1589                     (info (clone info #:locals locals)))
1590                (append-text info (append ((ident->accu info) value)
1591                                          ((accu->ident info) name))))
1592              (let* ((globals (append globals (list (ident->global name type 1 0))))
1593                     (here (data-offset name globals))
1594                     (there (data-offset value globals)))
1595                (clone info
1596                       #:globals globals
1597                       #:init (append (.init info)
1598                                      (list (lambda (functions globals ta t d data)
1599                                              (append
1600                                               (list-head data here)
1601                                               ;;; FIXME: type
1602                                               ;;; char *x = arena;
1603                                               (int->bv32 (+ d (data-offset value globals)))
1604                                               ;;; char *y = x;
1605                                               ;;;(list-head (list-tail data there) 4)
1606                                               (list-tail data (+ here 4))))))))))
1607
1608         ;; char *p = g_cells;
1609         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1610          (let ((type (decl->type type)))
1611            (if (.function info)
1612                (let* ((locals (add-local locals name type  1))
1613                       (info (clone info #:locals locals)))
1614                  (append-text info (append ((ident->accu info) value)
1615                                            ((accu->ident info) name))))
1616                (let* ((globals (append globals (list (ident->global name type 1 0))))
1617                       (here (data-offset name globals)))
1618                  (clone info
1619                         #:globals globals
1620                         #:init (append (.init info)
1621                                        (list (lambda (functions globals ta t d data)
1622                                                (append
1623                                                 (list-head data here)
1624                                               ;;; FIXME: type
1625                                               ;;; char *x = arena;p
1626                                                 (int->bv32 (+ d (data-offset value globals)))
1627                                                 (list-tail data (+ here 4)))))))))))
1628
1629         ;; enum
1630         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1631          (let ((type (enum->type name fields))
1632                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1633            (clone info
1634                   #:types (append (.types info) (list type))
1635                   #:constants (append constants (.constants info)))))
1636
1637         ;; struct
1638         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1639          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1640            (clone info #:types (append (.types info) (list type)))))
1641
1642         ;; char *p = &bla;
1643         ((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)))))))
1644          (let ((type (decl->type type)))
1645            (if (.function info)
1646                (let* ((locals (add-local locals name type 1))
1647                       (info (clone info #:locals locals)))
1648                  (append-text info (append ((ident-address->accu info) value)
1649                                            ((accu->ident info) name))))
1650                (error "TODO" o))))
1651
1652         ;; char **p = &bla;
1653         ((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)))))))
1654          (let ((type (decl->type type)))
1655            (if (.function info)
1656                (let* ((locals (add-local locals name type 2))
1657                       (info (clone info #:locals locals)))
1658                  (append-text info (append ((ident-address->accu info) value)
1659                                            ((accu->ident info) name))))
1660                (error "TODO" o))))
1661
1662         ;; char *p = bla[0];
1663         ((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)))))))
1664          (if (.function info)
1665              (let* ((locals (add-local locals name type 1))
1666                     (info (clone info #:locals locals))
1667                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1668                (append-text info ((accu->ident info) name)))
1669              (error "TODO" o)))
1670
1671         ;; char *p = *bla;
1672         ((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)))))))
1673          (if (.function info)
1674              (let* ((locals (add-local locals name type 2))
1675                     (info (clone info #:locals locals))
1676                     (local (assoc-ref (.locals info) name)))
1677                (append-text info (append ((ident->accu info) value)
1678                                          (wrap-as (i386:mem->accu))
1679                                          ((accu->ident info) name))))
1680              (error "TODO" o)))
1681
1682         ;; DECL
1683         ;; char *bla[] = {"a", "b"};
1684         ((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)))))
1685          (let* ((type (decl->type type))
1686                 (entries (map initzer->global initzers))
1687                 (entry-size 4)
1688                 (size (* (length entries) entry-size)))
1689            (if (.function info)
1690                (error "TODO: <type> x[] = {};" o)
1691                (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1692                       (globals (append globals entries (list global)))
1693                       (info (clone info #:globals globals))
1694                       (here (data-offset name globals)))
1695                  (clone info #:init
1696                         (append
1697                          (.init info)
1698                          (list (lambda (functions globals ta t d data)
1699                                  (append
1700                                   (list-head data here)
1701                                   (append-map
1702                                    (lambda (i)
1703                                      (initzer->data info functions globals ta t d i))
1704                                    initzers)
1705                                   (list-tail data (+ here size)))))))))))
1706
1707         ;;
1708         ;; struct f = {...};
1709         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1710          (let* ((type (decl->type type))
1711                 (fields (type->description info type))
1712                 (size (type->size info type))
1713                 (field-size 4))  ;; FIXME:4, not fixed
1714            (if (.function info)
1715                (let* ((globals (append globals (filter-map initzer->global initzers)))
1716                       (locals (let loop ((fields (cdr fields)) (locals locals))
1717                                 (if (null? fields) locals
1718                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1719                       (locals (add-local locals name type -1))
1720                       (info (clone info #:locals locals #:globals globals))
1721                       (empty (clone info #:text '())))
1722                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1723                    (if (null? fields) info
1724                        (let ((offset (* field-size (car fields)))
1725                              (initzer (car initzers)))
1726                          (loop (cdr fields) (cdr initzers)
1727                                (clone info #:text
1728                                       (append
1729                                        (.text info)
1730                                        ((ident->accu info) name)
1731                                        (wrap-as (append (i386:accu->base)))
1732                                        (.text ((expr->accu empty) initzer))
1733                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1734                (let* ((globals (append globals (filter-map initzer->global initzers)))
1735                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1736                       (globals (append globals (list global)))
1737                       (here (data-offset name globals))
1738                       (info (clone info #:globals globals))
1739                       (field-size 4))
1740                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1741                    (if (null? fields) info
1742                        (let ((offset (* field-size (car fields)))
1743                              (initzer (car initzers)))
1744                          (loop (cdr fields) (cdr initzers)
1745                                (clone info #:init
1746                                       (append
1747                                        (.init info)
1748                                        (list (lambda (functions globals ta t d data)
1749                                                (append
1750                                                 (list-head data (+ here offset))
1751                                                 (initzer->data info functions globals ta t d (car initzers))
1752                                                 (list-tail data (+ here offset field-size)))))))))))))))
1753
1754
1755         ;;char cc = g_cells[c].cdr;  ==> generic?
1756         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1757          (let ((type (decl->type type)))
1758            (if (.function info)
1759                (let* ((locals (add-local locals name type 0))
1760                       (info (clone info #:locals locals)))
1761                  (clone info #:text
1762                         (append (.text ((expr->accu info) initzer))
1763                                 ((accu->ident info) name))))
1764                (let* ((globals (append globals (list (ident->global name type 1 0))))
1765                       (here (data-offset name globals)))
1766                  (clone info
1767                         #:globals globals
1768                         #:init (append (.init info)
1769                                        (list (lambda (functions globals ta t d data)
1770                                                (append
1771                                                 (list-head data here)
1772                                                 (initzer->data info functions globals ta t d initzer)
1773                                                 (list-tail data (+ here 4)))))))))))
1774
1775
1776         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1777          info)
1778
1779         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1780          info)
1781
1782         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1783          (let ((types (.types info)))
1784            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1785
1786         ;; int foo ();
1787         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1788          info)
1789
1790         ;; void foo ();
1791         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1792          info)
1793
1794         ;; void foo (*);
1795         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1796          info)
1797
1798         ;; char const* itoa ();
1799         ((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))))))
1800          info)
1801
1802         ;; printf (char const* format, ...)
1803         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1804          info)
1805
1806         ;; int i = 0, j = 0;
1807         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
1808          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
1809            (if (null? inits) info
1810                (loop (cdr inits)
1811                      ((ast->info info)
1812                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
1813
1814         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1815          (format (current-error-port) "SKIP: typedef=~s\n" o)
1816          info)
1817
1818         ((decl (@ ,at))
1819          (format (current-error-port) "SKIP: at=~s\n" o)
1820          info)
1821
1822         ((decl . _) (error "ast->info: unsupported: " o))
1823
1824         ;; ...
1825         ((gt . _) ((expr->accu info) o))
1826         ((ge . _) ((expr->accu info) o))
1827         ((ne . _) ((expr->accu info) o))
1828         ((eq . _) ((expr->accu info) o))
1829         ((le . _) ((expr->accu info) o))
1830         ((lt . _) ((expr->accu info) o))
1831         ((lshift . _) ((expr->accu info) o))
1832         ((rshift . _) ((expr->accu info) o))
1833
1834         ;; EXPR
1835         ((expr-stmt ,expression)
1836          (let ((info ((expr->accu info) expression)))
1837            (append-text info (wrap-as (i386:accu-zero?)))))
1838
1839         ;; FIXME: why do we get (post-inc ...) here
1840         ;; (array-ref
1841         (_ (let ((info ((expr->accu info) o)))
1842              (append-text info (wrap-as (i386:accu-zero?)))))))))
1843
1844 (define (initzer->data info functions globals ta t d o)
1845   (pmatch o
1846     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1847     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1848     ((initzer (ref-to (p-expr (ident ,name))))
1849      (int->bv32 (+ ta (function-offset name functions))))
1850     ((initzer (p-expr (ident ,name)))
1851      (let ((value (assoc-ref (.constants info) name)))
1852        (int->bv32 value)))
1853     ((initzer (p-expr (string ,string)))
1854      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
1855     (_ (error "initzer->data: unsupported: " o))))
1856
1857 (define (.formals o)
1858   (pmatch o
1859     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1860     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1861     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
1862     (_ (error ".formals: " o))))
1863
1864 (define (formal->text n)
1865   (lambda (o i)
1866     ;;(i386:formal i n)
1867     '()
1868     ))
1869
1870 (define (formals->text o)
1871   (pmatch o
1872     ((param-list . ,formals)
1873      (let ((n (length formals)))
1874        (wrap-as (append (i386:function-preamble)
1875                         (append-map (formal->text n) formals (iota n))
1876                         (i386:function-locals)))))
1877     (_ (error "formals->text: unsupported: " o))))
1878
1879 (define (formal:ptr o)
1880   (pmatch o
1881     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
1882      0)
1883     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
1884      2)
1885     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
1886      1)
1887     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1888      1)
1889     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
1890      2)
1891     (_
1892      (stderr "formal:ptr[~a] => ~a\n" o 0)
1893      0)))
1894
1895 (define (formals->locals o)
1896   (pmatch o
1897     ((param-list . ,formals)
1898      (let ((n (length formals)))
1899        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
1900     (_ (error "formals->locals: unsupported: " o))))
1901
1902 (define (function->info info)
1903   (lambda (o)
1904     (let* ((name (.name o))
1905            (formals (.formals o))
1906            (text (formals->text formals))
1907            (locals (formals->locals formals)))
1908       (format (current-error-port) "compiling: ~a\n" name)
1909       (let loop ((statements (.statements o))
1910                  (info (clone info #:locals locals #:function (.name o) #:text text)))
1911         (if (null? statements) (clone info
1912                                       #:function #f
1913                                       #:functions (append (.functions info) (list (cons name (.text info)))))
1914             (let* ((statement (car statements)))
1915               (loop (cdr statements)
1916                     ((ast->info info) (car statements)))))))))
1917
1918 (define (ast-list->info info)
1919   (lambda (elements)
1920     (let loop ((elements elements) (info info))
1921       (if (null? elements) info
1922           (loop (cdr elements) ((ast->info info) (car elements)))))))
1923
1924 (define (c99-input->info)
1925   (let* ((info (make <info>
1926                  #:functions i386:libc
1927                  #:types i386:type-alist))
1928          (foo (stderr "compiling: mlibc\n"))
1929          (info (let loop ((info info) (libc libc))
1930                  (if (null? libc) info
1931                      (loop ((ast->info info) ((car libc))) (cdr libc)))))
1932          (foo (stderr "parsing: input\n"))
1933          (ast (c99-input->ast))
1934          (foo (stderr "compiling: input\n"))
1935          (info ((ast->info info) ast))
1936          (info ((ast->info info) (_start))))
1937     info))
1938
1939 (define (write-any x)
1940   (write-char (cond ((char? x) x)
1941                     ((and (number? x) (< (+ x 256) 0))
1942                      (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
1943                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
1944                     ((procedure? x)
1945                      (stderr "write-any: proc: ~a\n" x)
1946                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
1947                      (error "procedure: write-any:" x))
1948                     (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
1949
1950 (define (info->elf info)
1951   (display "dumping elf\n" (current-error-port))
1952   (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
1953
1954 (define (c99-input->elf)
1955   ((compose info->elf c99-input->info)))