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