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