module/mescc/compile.scm

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