module/mescc/compile.scm

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