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