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