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