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