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