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