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