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