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