module/language/c99/compiler.mes

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