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