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