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