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