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