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