mescc: Bugfix for break in switch not in compound.
[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 (if (or (null? locals) (not (local? (cdar locals)))) 1
515                        (1+ (local:id (cdar locals)))))
516                (locals (cons (make-local name type pointer id) locals)))
517           locals))
518       (pmatch o
519         ((p-expr (string ,string))
520          (let* ((globals (append globals (list (string->global string))))
521                 (info (clone info #:globals globals)))
522            (append-text info (list (lambda (f g ta t d)
523                                      (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
524
525         ((p-expr (string . ,strings))
526          (append-text info (list (lambda (f g ta t d)
527                                    (i386:global->accu (+ (data-offset (add-s:-prefix (apply string-append strings)) globals) d))))))
528         ((p-expr (fixed ,value))
529          (append-text info (value->accu (cstring->number value))))
530
531         ((p-expr (ident ,name))
532          (append-text info ((ident->accu info) name)))
533
534         ((initzer ,initzer) ((expr->accu info) initzer))
535         ((ref-to (p-expr (ident ,name)))
536          (append-text info ((ident->accu info) name)))
537
538         ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
539          (let* ((type (list "struct" name))
540                 (fields (or (type->description info type) '()))
541                 (size (type->size info type)))
542            (append-text info (wrap-as (i386:value->accu size)))))
543         
544         ;; c+p expr->arg
545         ;; g_cells[<expr>]
546         ((array-ref ,index (p-expr (ident ,array)))
547          (let* ((type (ident->type info array))
548                 (ptr (ident->pointer info array))
549                 (size (if (< ptr 2) (type->size info type)
550                           4))
551                 (info ((expr->accu* info) o)))
552            (append-text info (wrap-as (append (case size
553                                                 ((1) (i386:byte-mem->accu))
554                                                 ((4) (i386:mem->accu))
555                                                 (else '())))))))
556
557         ;; f.field
558         ((d-sel (ident ,field) (p-expr (ident ,array)))
559          (let* ((type (ident->type info array))
560                 (fields (type->description info type))
561                 (field-size 4) ;; FIXME:4, not fixed
562                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
563                 (text (.text info)))
564            (append-text info (append ((ident->accu info) array)
565                                      (wrap-as (i386:mem+n->accu offset))))))
566
567         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
568          (let* ((type (ident->type info array))
569                 (fields (or (type->description info type) '()))
570                 (field-size 4) ;; FIXME:4, not fixed
571                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
572                           (begin
573                             (stderr "no field:~a\n" field)
574                             '())))
575                 (offset (* field-size (1- (length rest))))
576                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
577            (append-text info (wrap-as (i386:mem+n->accu offset)))))
578
579         ;;; FIXME: FROM INFO ...only zero?!
580         ((p-expr (fixed ,value))
581          (let ((value (cstring->number value)))
582            (append-text info (wrap-as (i386:value->accu value)))))
583
584         ((p-expr (char ,char))
585          (let ((char (char->integer (car (string->list char)))))
586            (append-text info (wrap-as (i386:value->accu char)))))
587
588         ((p-expr (ident ,name))
589          (append-text info ((ident->accu info) name)))
590
591         ((de-ref (p-expr (ident ,name)))
592          (let* ((type (ident->type info name))
593                 (ptr (ident->pointer info name))
594                 (size (if (= ptr 1) (type->size info type)
595                           4)))
596            (append-text info (append ((ident->accu info) name)
597                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
598                                                   (i386:mem->accu)))))))
599
600         ((de-ref (post-inc (p-expr (ident ,name))))
601          (let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
602                 (type (ident->type info name))
603                 (ptr (ident->pointer info name))
604                 (size (if (> ptr 1) 4 1)))
605            (append-text info ((ident-add info) name size))))
606
607         ((de-ref ,expr)
608          (let ((info ((expr->accu info) expr)))
609            (append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
610
611         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
612          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
613                                    (append-text info (wrap-as (asm->hex arg0))))
614              (let* ((text-length (length text))
615                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
616                                  (if (null? expressions) info
617                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
618                     (n (length expr-list)))
619                (if (and (not (assoc-ref locals name))
620                         (assoc-ref (.functions info) name))
621                    (append-text args-info (list (lambda (f g ta t d)
622                                                   (i386:call f g ta t d (+ t (function-offset name f)) n))))
623                    (let* ((empty (clone info #:text '()))
624                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
625                      (append-text args-info (append (.text accu)
626                                                     (list (lambda (f g ta t d)
627                                                             (i386:call-accu f g ta t d n))))))))))
628
629         ((fctn-call ,function (expr-list . ,expr-list))
630          (let* ((text-length (length text))
631                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
632                              (if (null? expressions) info
633                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
634                 (n (length expr-list))
635                 (empty (clone info #:text '()))
636                 (accu ((expr->accu empty) function)))
637            (append-text args-info (append (.text accu)
638                                           (list (lambda (f g ta t d)
639                                                   (i386:call-accu f g ta t d n)))))))
640
641         ((cond-expr . ,cond-expr)
642          ((ast->info info) `(expr-stmt ,o)))
643
644         ((post-inc (p-expr (ident ,name)))
645          (let* ((type (ident->type info name))
646                 (ptr (ident->pointer info name))
647                 (size (if (> ptr 1) 4 1)))
648            (append-text info (append ((ident->accu info) name)
649                                      ((ident-add info) name size)))))
650
651         ((post-dec (p-expr (ident ,name)))
652          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
653          (append-text info (append ((ident->accu info) name)
654                                    ((ident-add info) name -1))))
655
656         ((pre-inc (p-expr (ident ,name)))
657          (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) (error "undefined identifier: " name)))
658          (append-text info (append ((ident-add info) name 1)
659                                    ((ident->accu info) name))))
660
661         ((pre-dec (p-expr (ident ,name)))
662          (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) (error "undefined identifier: " name)))
663          (append-text info (append ((ident-add info) name -1)
664                                    ((ident->accu info) name))))
665
666         ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
667         ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
668         ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
669         ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
670         ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
671         ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
672         ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
673         ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
674
675         ((not ,expr)
676          (let* ((test-info ((ast->info info) expr)))
677            (clone info #:text
678                   (append (.text test-info)
679                           (wrap-as (i386:accu-not)))
680                   #:globals (.globals test-info))))
681
682         ((neg (p-expr (fixed ,value)))
683          (append-text info (value->accu (- (cstring->number value)))))
684
685         ((neg (p-expr (ident ,name)))
686          (append-text info (append ((ident->base info) name)
687                                    (wrap-as (i386:value->accu 0))
688                                    (wrap-as (i386:sub-base)))))
689
690         ((eq ,a ,b) ((binop->accu info) a b (i386:sub-base)))
691         ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
692         ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
693         ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base)
694                                                     (i386:xor-zf))))
695         ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
696         ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
697
698         ((cast ,cast ,o)
699          ((expr->accu info) o))
700
701         ((assn-expr ,a (op ,op) ,b)
702          (let* ((info ((expr->accu info) b))
703                 (info (if (equal? op "=") info
704                           (let* ((info (append-text info (wrap-as (i386:push-accu))))
705                                  (info ((expr->accu info) a))
706                                  (info (append-text info (wrap-as (i386:pop-base)))))
707                             (append-text info (cond ((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%base)))
712                                                     ((equal? op "|=") (wrap-as (i386:accu-or-base)))
713                                                     (else (error "mescc: op ~a not supported: ~a\n" op o))))))))
714            (pmatch a
715              ((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
716              ((d-sel (ident ,field) ,p-expr)
717               (let* ((type (p-expr->type info p-expr))
718                      (fields (type->description info type))
719                      (size (type->size info type))
720                      (field-size 4) ;; FIXME:4, not fixed
721                      (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                
722                      (info (append-text info (wrap-as (i386:push-accu))))
723                      (info ((expr->accu* info) a))
724                      (info (append-text info (wrap-as (i386:pop-base)))))
725                 (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
726              ;; FIXME: c&p above
727              ((de-ref (p-expr (ident ,array)))
728               (append-text info (append (wrap-as (i386:accu->base))
729                                         ((base->ident-address info) array)
730                                         (wrap-as (i386:base->accu)))))
731              ((de-ref (post-inc (p-expr (ident ,name))))
732               (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
733                 (append-text info ((ident-add info) name 1))))
734              ((de-ref (post-dec (p-expr (ident ,name))))
735               (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
736                 (append-text info ((ident-add info) name -1))))
737              ((array-ref ,index (p-expr (ident ,array)))
738               (let* ((type (ident->type info array))
739                      (size (type->size info type))
740                      (info (append-text info (wrap-as (append (i386:push-accu)))))
741                      (info ((expr->accu* info) a))
742                      (info (append-text info (wrap-as (append (i386:pop-base))))))
743                 (append-text info
744                              (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
745                                          (if (<= size 4) (wrap-as (i386:base->accu-address))
746                                           (append
747                                            (wrap-as (i386:base-address->accu-address))
748                                            (wrap-as (append (i386:accu+n 4)
749                                                             (i386:base+n 4)
750                                                             (i386:base-address->accu-address)))
751                                            (if (<= size 8) '()
752                                                (wrap-as (append (i386:accu+n 4)
753                                                                 (i386:base+n 4)
754                                                                 (i386:base-address->accu-address)))))))))))
755              (_ (error "expr->accu: unsupported assign: " a)))))
756
757         (_ (error "expr->accu: unsupported: " o))))))
758
759 (define (expr->base info)
760   (lambda (o)
761     (let* ((info (append-text info (wrap-as (i386:push-accu))))
762            (info ((expr->accu info) o))
763            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
764       info)))
765
766 (define (binop->accu info)
767   (lambda (a b c)
768     (let* ((info ((expr->accu info) a))
769            (info ((expr->base info) b)))
770       (append-text info (wrap-as c)))))
771
772 (define (append-text info text)
773   (clone info #:text (append (.text info) text)))
774
775 (define (wrap-as o)
776   (list (lambda (f g ta t d) o)))
777
778 (define (expr->accu* info)
779   (lambda (o)
780     (pmatch o
781       ;; g_cells[<expr>]
782       ((array-ref ,index (p-expr (ident ,array)))
783        (let* ((info ((expr->accu info) index))
784               (type (ident->type info array))
785               (ptr (ident->pointer info array))
786               (size (if (< ptr 2) (type->size info type)
787                         4)))
788          (append-text info (append (wrap-as (append (i386:accu->base)
789                                                     (if (eq? size 1) '()
790                                                         (append
791                                                          (if (<= size 4) '()
792                                                              (i386:accu+accu))
793                                                          (if (<= size 8) '()
794                                                              (i386:accu+base))
795                                                          (i386:accu-shl 2)))))
796                                    ((ident->base info) array)
797                                    (wrap-as (i386:accu+base))))))
798
799       ;; g_cells[<expr>].type
800       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
801        (let* ((type (ident->type info array))
802               (fields (or (type->description info type) '()))
803               (field-size 4) ;; FIXME:4, not fixed
804               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
805               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
806          (append-text info (wrap-as (append (i386:accu+value offset))))))
807
808       ((d-sel (ident ,field) (p-expr (ident ,name)))
809        (let* ((type (ident->type info name))
810               (fields (or (type->description info type) '()))
811               (field-size 4) ;; FIXME
812               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
813               (text (.text info)))
814          (append-text info (append ((ident->accu info) name)
815                                    (wrap-as (i386:accu+value offset))))))
816
817       (_ (error "expr->accu*: unsupported: " o)))))
818
819 (define (ident->constant name value)
820   (cons name value))
821
822 (define (make-type name type size description)
823   (cons name (list type size description)))
824
825 (define (enum->type name fields)
826   (make-type name 'enum 4 fields))
827
828 (define (struct->type name fields)
829   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
830
831 (define (decl->type o)
832   (pmatch o
833     ((fixed-type ,type) type)
834     ((struct-ref (ident ,name)) (list "struct" name))
835     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
836      (list "struct" name)) ;; FIXME
837     ((typename ,name) name)
838     (,name name)
839     (_ (error "decl->type: unsupported: " o))))
840
841 (define (expr->global o)
842   (pmatch o
843     ((p-expr (string ,string)) (string->global string))
844     ((p-expr (fixed ,value)) (int->global (cstring->number value)))
845     (_ #f)))
846
847 (define (initzer->global o)
848   (pmatch o
849     ((initzer ,initzer) (expr->global initzer))
850     (_ #f)))
851
852 (define (byte->hex o)
853   (string->number (string-drop o 2) 16))
854
855 (define (asm->hex o)
856   (let ((prefix ".byte "))
857     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
858         (let ((s (string-drop o (string-length prefix))))
859           (map byte->hex (string-split s #\space))))))
860
861 (define (clause->jump-info info)
862   (define (jump n)
863     (wrap-as (i386:Xjump n)))
864   (define (jump-nz n)
865     (wrap-as (i386:Xjump-nz n)))
866   (define (jump-z n)
867     (wrap-as (i386:Xjump-z n)))
868   (define (statement->info info body-length)
869     (lambda (o)
870       (pmatch o
871         ((break) (append-text info (jump body-length)))
872         (_ ((ast->info info) o)))))
873   (define (test->text test)
874     (let ((value (pmatch test
875                    (0 0)
876                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
877                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
878                    ((p-expr (fixed ,value)) (cstring->number value))
879                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
880                    (_ (error "case test: unsupported: " test)))))
881       (lambda (n)
882         (append (wrap-as (i386:accu-cmp-value value))
883                 (jump-z (+ (length (text->list (jump 0)))
884                            (if (= n 0) 0
885                                (* n (length (text->list ((test->text 0) 0)))))))))))
886   (define (cases+jump cases clause-length)
887     (append-text info
888                  (append
889                   (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
890                   (if (null? cases) '()
891                       (jump clause-length)))))
892   (lambda (o)
893     (lambda (body-length)
894       (let loop ((o o) (cases '()) (clause #f))
895         (pmatch o
896           ((case ,test ,statement)
897            (loop statement (append cases (list (test->text test))) clause))
898           ((default ,statement)
899            (loop statement cases clause))
900           ((compd-stmt (block-item-list))
901            (loop '() cases clause))
902           ((compd-stmt (block-item-list . ,elements))
903            (let ((clause (or clause (cases+jump cases 0))))
904              (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
905                    ((statement->info clause body-length) (car elements)))))
906           (()
907            (let* ((cases-length (length (.text (cases+jump cases 0))))
908                   (clause-text (list-tail (.text clause) cases-length))
909                   (clause-length (length (text->list clause-text))))
910              (clone clause #:text
911                     (append (.text (cases+jump cases clause-length))
912                             clause-text))))
913           (_
914            (let ((clause (or clause (cases+jump cases 0))))
915              (loop '() cases
916                    ((statement->info clause body-length) o)))))))))
917
918 (define (test->jump->info info)
919   (define (jump type . test)
920     (lambda (o)
921       (let* ((text (.text info))
922              (info (clone info #:text '()))
923              (info ((ast->info info) o))
924              (jump-text (lambda (body-length)
925                           (wrap-as (type body-length)))))
926         (lambda (body-length)
927           (clone info #:text
928                  (append text
929                          (.text info)
930                          (if (null? test) '() (car test))
931                          (jump-text body-length)))))))
932   (lambda (o)
933     (pmatch o
934       ;; unsigned
935       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
936       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
937       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
938       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
939
940       ((le ,a ,b) ((jump i386:Xjump-g) o))
941       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
942       ((ge ,a ,b) ((jump i386:Xjump-g) o))
943       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
944
945       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
946       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
947       ((not _) ((jump i386:Xjump-z) o))
948       ((and ,a ,b)
949        (let* ((globals (.globals info))
950               (text (.text info))
951               (info (clone info #:text '()))
952
953               (a-jump ((test->jump->info info) a))
954               (a-text (.text (a-jump 0)))
955               (a-length (length (text->list a-text)))
956
957               (b-jump ((test->jump->info info) b))
958               (b-text (.text (b-jump 0)))
959               (b-length (length (text->list b-text))))
960
961          (lambda (body-length)
962            (let* ((info (append-text info text))
963                   (a-info (a-jump (+ b-length body-length)))
964                   (info (append-text info (.text a-info)))
965                   (b-info (b-jump body-length))
966                   (info (append-text info (.text b-info))))
967             (clone info
968                    #:globals (append globals
969                                      (list-tail (.globals a-info) (length globals))
970                                      (list-tail (.globals b-info) (length globals))))))))
971
972       ((or ,a ,b)
973        (let* ((globals (.globals info))
974               (text (.text info))
975               (info (clone info #:text '()))
976
977               (a-jump ((test->jump->info info) a))
978               (a-text (.text (a-jump 0)))
979               (a-length (length (text->list a-text)))
980
981               (jump-text (wrap-as (i386:Xjump 0)))
982               (jump-length (length (text->list jump-text)))
983
984               (b-jump ((test->jump->info info) b))
985               (b-text (.text (b-jump 0)))
986               (b-length (length (text->list b-text)))
987
988               (jump-text (wrap-as (i386:Xjump b-length))))
989
990          (lambda (body-length)
991            (let* ((info (append-text info text))
992                   (a-info (a-jump jump-length))
993                   (info (append-text info (.text a-info)))
994                   (info (append-text info jump-text))
995                   (b-info (b-jump body-length))
996                   (info (append-text info (.text b-info))))
997             (clone info
998                    #:globals (append globals
999                                      (list-tail (.globals a-info) (length globals))
1000                                      (list-tail (.globals b-info) (length globals))))))))
1001
1002       ((array-ref . _) ((jump i386:jump-byte-z
1003                               (wrap-as (i386:accu-zero?))) o))
1004
1005       ((de-ref _) ((jump i386:jump-byte-z
1006                          (wrap-as (i386:accu-zero?))) o))
1007
1008       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1009        ((jump i386:Xjump-z
1010               (append
1011                ((ident->accu info) name)
1012                (wrap-as (i386:accu-zero?)))) o))
1013
1014       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1015
1016 (define (cstring->number s)
1017   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1018         ((string-prefix? "0" s) (string->number s 8))
1019         (else (string->number s))))
1020
1021 (define (struct-field o)
1022   (pmatch o
1023     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1024                 (comp-declr-list (comp-declr (ident ,name))))
1025      (cons type name))
1026     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1027      (cons type name))
1028     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1029      (cons type name))
1030     ((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)))))))))
1031      (cons type name)) ;; FIXME function / int
1032     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1033      (cons type name)) ;; FIXME: ptr/char
1034     (_ (error "struct-field: unsupported: " o))))
1035
1036 (define (ast->type o)
1037   (pmatch o
1038     ((fixed-type ,type)
1039      type)
1040     ((struct-ref (ident ,type))
1041      (list "struct" type))
1042     (_ (stderr "SKIP: type=~s\n" o)
1043        "int")))
1044
1045 (define i386:type-alist
1046   '(("char" . (builtin 1 #f))
1047     ("int" . (builtin 4 #f))))
1048
1049 (define (type->size info o)
1050   (pmatch o
1051     ((decl-spec-list (type-spec (fixed-type ,type)))
1052      (type->size info type))
1053     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1054      (type->size info type))
1055     (_ (let ((type (assoc-ref (.types info) o)))
1056          (if type (cadr type)
1057              (error "type->size: unsupported: " o))))))
1058
1059 (define (ident->decl info o)
1060   (or (assoc-ref (.locals info) o)
1061       (assoc-ref (.globals info) o)
1062       (begin
1063         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1064         (assoc-ref (.functions info) o))))
1065
1066 (define (ident->type info o)
1067   (and=> (ident->decl info o) car))
1068
1069 (define (ident->pointer info o)
1070   (let ((local (assoc-ref (.locals info) o)))
1071     (if local (local:pointer local)
1072         (or (and=> (ident->decl info o) global:pointer) 0))))
1073
1074 (define (p-expr->type info o)
1075   (pmatch o
1076     ((p-expr (ident ,name)) (ident->type info name))
1077     ((array-ref ,index (p-expr (ident ,array)))
1078      (ident->type info array))
1079     (_ (error "p-expr->type: unsupported: " o))))
1080
1081 (define (type->description info o)
1082   (pmatch o
1083     ((decl-spec-list (type-spec (fixed-type ,type)))
1084      (type->description info type))
1085     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1086      (type->description info type))
1087     (_ (let ((type (assoc-ref (.types info) o)))
1088          (if (not type) (stderr "TYPES=~s\n" (.types info)))
1089          (if type (caddr type)
1090              (error "type->description: unsupported:" o))))))
1091
1092 (define (local? o) ;; formals < 0, locals > 0
1093   (positive? (local:id o)))
1094
1095 (define (statements->clauses statements)
1096   (let loop ((statements statements) (clauses '()))
1097     (if (null? statements) clauses
1098         (let ((s (car statements)))
1099           (pmatch s
1100             ((case ,test (compd-stmt (block-item-list . _)))
1101              (loop (cdr statements) (append clauses (list s))))
1102             ((case ,test (break))
1103              (loop (cdr statements) (append clauses (list s))))
1104             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1105
1106             ((case ,test ,statement)
1107              (let loop2 ((statement statement) (heads `((case ,test))))
1108                (define (heads->case heads statement)
1109                  (if (null? heads) statement
1110                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1111                (pmatch statement
1112                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1113                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1114                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1115                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1116                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1117                           (let ((s (car statements)))
1118                             (pmatch s
1119                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1120                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1121                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1122                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1123             ((default (compd-stmt (block-item-list _)))
1124              (loop (cdr statements) (append clauses (list s))))
1125             ((default . ,statement)
1126              (let loop2 ((statements (cdr statements)) (c statement))
1127                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1128                    (let ((s (car statements)))
1129                      (pmatch s
1130                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1131                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1132                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1133                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1134
1135                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1136             (_ (error "statements->clauses: unsupported:" s)))))))
1137
1138 (define (ast->info info)
1139   (lambda (o)
1140     (let ((globals (.globals info))
1141           (locals (.locals info))
1142           (constants (.constants info))
1143           (text (.text info)))
1144       (define (add-local locals name type pointer)
1145         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1146                        (1+ (local:id (cdar locals)))))
1147                (locals (cons (make-local name type pointer id) locals)))
1148           locals))
1149
1150       (pmatch o
1151         (((trans-unit . _) . _)
1152          ((ast-list->info info)  o))
1153         ((trans-unit . ,elements)
1154          ((ast-list->info info) elements))
1155         ((fctn-defn . _) ((function->info info) o))
1156         ((comment . _) info)
1157         ((cpp-stmt (define (name ,name) (repl ,value)))
1158          info)
1159
1160         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1161          info)
1162
1163         ((break)
1164          (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (text->list text)))))))
1165
1166         ;; FIXME: expr-stmt wrapper?
1167         (trans-unit info)
1168         ((expr-stmt) info)
1169
1170         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1171         
1172         ((if ,test ,body)
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                 (body-info ((ast->info test+jump-info) body))
1180                 (text-body-info (.text body-info))
1181                 (body-text (list-tail text-body-info test-length))
1182                 (body-length (length (text->list body-text)))
1183
1184                 (text+test-text (.text (test-jump->info body-length)))
1185                 (test-text (list-tail text+test-text text-length)))
1186
1187            (clone info #:text
1188                   (append text
1189                           test-text
1190                           body-text)
1191                   #:globals (.globals body-info))))
1192
1193         ((if ,test ,then ,else)
1194          (let* ((text-length (length text))
1195
1196                 (test-jump->info ((test->jump->info info) test))
1197                 (test+jump-info (test-jump->info 0))
1198                 (test-length (length (.text test+jump-info)))
1199
1200                 (then-info ((ast->info test+jump-info) then))
1201                 (text-then-info (.text then-info))
1202                 (then-text (list-tail text-then-info test-length))
1203                 (then-jump-text (wrap-as (i386:Xjump 0)))
1204                 (then-jump-length (length (text->list then-jump-text)))
1205                 (then-length (+ (length (text->list then-text)) then-jump-length))
1206
1207                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1208                 (else-info ((ast->info then+jump-info) else))
1209                 (text-else-info (.text else-info))
1210                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1211                 (else-length (length (text->list else-text)))
1212
1213                 (text+test-text (.text (test-jump->info then-length)))
1214                 (test-text (list-tail text+test-text text-length))
1215                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1216
1217            (clone info #:text
1218                   (append text
1219                           test-text
1220                           then-text
1221                           then-jump-text
1222                           else-text)
1223                   #:globals (append (.globals then-info)
1224                                     (list-tail (.globals else-info) (length globals))))))
1225
1226         ;; Hmm?
1227         ((expr-stmt (cond-expr ,test ,then ,else))
1228          (let* ((text-length (length text))
1229
1230                 (test-jump->info ((test->jump->info info) test))
1231                 (test+jump-info (test-jump->info 0))
1232                 (test-length (length (.text test+jump-info)))
1233
1234                 (then-info ((ast->info test+jump-info) then))
1235                 (text-then-info (.text then-info))
1236                 (then-text (list-tail text-then-info test-length))
1237                 (then-length (length (text->list then-text)))
1238
1239                 (jump-text (wrap-as (i386:Xjump 0)))
1240                 (jump-length (length (text->list jump-text)))
1241
1242                 (test+then+jump-info
1243                  (clone then-info
1244                         #:text (append (.text then-info) jump-text)))
1245
1246                 (else-info ((ast->info test+then+jump-info) else))
1247                 (text-else-info (.text else-info))
1248                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1249                 (else-length (length (text->list else-text)))
1250
1251                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1252                 (test-text (list-tail text+test-text text-length))
1253                 (jump-text (wrap-as (i386:Xjump else-length))))
1254
1255            (clone info #:text
1256                   (append text
1257                           test-text
1258                           then-text
1259                           jump-text
1260                           else-text)
1261                   #:globals (.globals else-info))))
1262
1263         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1264          (let* ((clauses (statements->clauses statements))
1265                 (expr ((expr->accu info) expr))
1266                 (empty (clone info #:text '()))
1267                 (clause-infos (map (clause->jump-info empty) clauses))
1268                 (clause-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) clause-infos))
1269                 (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
1270                               (if (null? clauses) info
1271                                   (let ((c-j ((clause->jump-info info) (car clauses))))
1272                                     (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1273            clauses-info))
1274
1275         ((for ,init ,test ,step ,body)
1276          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1277
1278                 (info ((ast->info info) init))
1279
1280                 (init-text (.text info))
1281                 (init-locals (.locals info))
1282                 (info (clone info #:text '()))
1283
1284                 (body-info ((ast->info info) body))
1285                 (body-text (.text body-info))
1286                 (body-length (length (text->list body-text)))
1287
1288                 (step-info ((expr->accu info) step))
1289                 (step-text (.text step-info))
1290                 (step-length (length (text->list step-text)))
1291
1292                 (test-jump->info ((test->jump->info info) test))
1293                 (test+jump-info (test-jump->info 0))
1294                 (test-length (length (text->list (.text test+jump-info))))
1295
1296                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1297
1298                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1299                 (jump-length (length (text->list jump-text)))
1300
1301                 (test-text (.text (test-jump->info jump-length))))
1302
1303            (clone info #:text
1304                   (append text
1305                           init-text
1306                           skip-body-text
1307                           body-text
1308                           step-text
1309                           test-text
1310                           jump-text)
1311                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1312                   #:locals locals)))
1313
1314         ((while ,test ,body)
1315          (let* ((skip-info (lambda (body-length test-length)
1316                              (clone info
1317                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1318                                     #:break (cons (+ (length (text->list text)) body-length test-length
1319                                                      (length (i386:Xjump 0)))
1320                                                   (.break info)))))
1321                 (text (.text (skip-info 0 0)))
1322                 (text-length (length text))
1323                 (body-info (lambda (body-length test-length)
1324                              ((ast->info (skip-info body-length test-length)) body)))
1325
1326                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1327                 (body-length (length (text->list body-text)))
1328
1329                 (empty (clone info #:text '()))
1330                 (test-jump->info ((test->jump->info empty) test))
1331                 (test+jump-info (test-jump->info 0))
1332                 (test-length (length (text->list (.text test+jump-info))))
1333
1334                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1335                 (jump-length (length (text->list jump-text)))
1336
1337                 (test-text (.text (test-jump->info jump-length)))
1338
1339                 (body-info (body-info body-length (length (text->list test-text)))))
1340
1341            (clone info #:text
1342                   (append
1343                    (.text body-info)
1344                    test-text
1345                    jump-text)
1346                   #:globals (.globals body-info))))
1347
1348         ((do-while ,body ,test)
1349          (let* ((text-length (length text))
1350
1351                 (body-info ((ast->info info) body))
1352                 (body-text (list-tail (.text body-info) text-length))
1353                 (body-length (length (text->list body-text)))
1354
1355                 (empty (clone info #:text '()))
1356                 (test-jump->info ((test->jump->info empty) test))
1357                 (test+jump-info (test-jump->info 0))
1358                 (test-length (length (text->list (.text test+jump-info))))
1359
1360                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1361                 (jump-length (length (text->list jump-text)))
1362
1363                 (test-text (.text (test-jump->info jump-length))))
1364            (clone info #:text
1365                   (append
1366                    (.text body-info)
1367                    test-text
1368                    jump-text)
1369                   #:globals (.globals body-info))))
1370
1371         ((labeled-stmt (ident ,label) ,statement)
1372          (let ((info (append-text info (list label))))
1373            ((ast->info info) statement)))
1374
1375         ((goto (ident ,label))
1376          (let* ((jump (lambda (n) (i386:XXjump n)))
1377                 (offset (+ (length (jump 0)) (length (text->list text)))))
1378            (append-text info (append 
1379                               (list (lambda (f g ta t d)
1380                                       (jump (- (label-offset (.function info) label f) offset))))))))
1381
1382         ((return ,expr)
1383          (let ((info ((expr->accu info) expr)))
1384            (append-text info (append  (wrap-as (i386:ret)))))) 
1385
1386         ;; DECL
1387
1388         ;; int i;
1389         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1390          (if (.function info)
1391              (clone info #:locals (add-local locals name type 0))
1392              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1393
1394         ;; int i = 0;
1395         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1396          (let ((value (cstring->number value)))
1397            (if (.function info)
1398                (let* ((locals (add-local locals name type 0))
1399                       (info (clone info #:locals locals)))
1400                  (append-text info ((value->ident info) name value)))
1401                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1402
1403         ;; char c = 'A';
1404         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1405          (if (not (.function info)) (error "ast->info: unsupported: " o))
1406          (let* ((locals (add-local locals name type 0))
1407                 (info (clone info #:locals locals))
1408                 (value (char->integer (car (string->list value)))))
1409            (append-text info ((value->ident info) name value))))
1410
1411         ;; int i = -1;
1412         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1413          (let ((value (- (cstring->number value))))
1414            (if (.function info)
1415                (let* ((locals (add-local locals name type 0))
1416                       (info (clone info #:locals locals)))
1417                  (append-text info ((value->ident info) name value)))
1418                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1419
1420         ;; int i = argc;
1421         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1422          (if (not (.function info)) (error "ast->info: unsupported: " o))
1423          (let* ((locals (add-local locals name type 0))
1424                 (info (clone info #:locals locals)))
1425            (append-text info (append ((ident->accu info) local)
1426                                      ((accu->ident info) name)))))
1427
1428         ;; char *p = "foo";
1429         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1430          (if (.function info)
1431              (let* ((locals (add-local locals name type 1))
1432                     (globals (append globals (list (string->global string))))
1433                     (info (clone info #:locals locals #:globals globals)))
1434                (append-text info (append
1435                                   (list (lambda (f g ta t d)
1436                                           (append
1437                                            (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1438                                   ((accu->ident info) name))))
1439              (let* ((global (string->global string))
1440                     (globals (append globals (list global)))
1441                     (size 4)
1442                     (global (make-global name type 1 (string->list (make-string size #\nul))))
1443                     (globals (append globals (list global)))
1444                     (info (clone info #:globals globals))
1445                     (here (data-offset name globals)))
1446                (clone info #:init
1447                       (append
1448                        (.init info)
1449                        (list (lambda (functions globals ta t d data)
1450                                (append
1451                                 (list-head data here)
1452                                 (initzer->data info functions globals ta t d `(initzer (p-expr (string ,string))))
1453                                 (list-tail data (+ here size))))))))))
1454         
1455         ;; char const *p;
1456         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1457          (if (.function info)
1458              (let* ((locals (add-local locals name type 1))
1459                     (info (clone info #:locals locals)))
1460                (append-text info (append (wrap-as (i386:value->accu 0))
1461                                          ((accu->ident info) name))))
1462              (let ((globals (append globals (list (ident->global name type 1 0)))))
1463                (clone info #:globals globals))))
1464
1465         ;; char *p;
1466         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1467          (if (.function info)
1468              (let* ((locals (add-local locals name type 1))
1469                     (info (clone info #:locals locals)))
1470                (append-text info (append (wrap-as (i386:value->accu 0))
1471                                          ((accu->ident info) name))))
1472              (let ((globals (append globals (list (ident->global name type 1 0)))))
1473                (clone info #:globals globals))))
1474
1475         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1476          (let ((value (cstring->number value)))
1477            (if (.function info)
1478                (let* ((locals (add-local locals name type 1))
1479                       (info (clone info #:locals locals)))
1480                  (append-text info (append (wrap-as (i386:value->accu value))
1481                                            ((accu->ident info) name))))
1482                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1483
1484         ;; char **p;
1485         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1486          (if (.function info)
1487              (let* ((locals (add-local locals name type 2))
1488                     (info (clone info #:locals locals)))
1489                (append-text info (append (wrap-as (i386:value->accu 0))
1490                                          ((accu->ident info) name))))
1491              (let ((globals (append globals (list (ident->global name type 2 0)))))
1492                (clone info #:globals globals))))
1493
1494         ;; char **p = 0;
1495         ;;((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)))))))
1496
1497         ;; char **p = g_environment;
1498         ((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
1499          (if (.function info)
1500              (let* ((locals (add-local locals name type 2))
1501                     (info (clone info #:locals locals)))
1502                (append-text info (append
1503                                   ((ident->accu info) b)
1504                                   ((accu->ident info) name))))
1505              (let* ((globals (append globals (list (ident->global name type 2 0))))
1506                     (here (data-offset name globals)))
1507                (clone info
1508                       #:globals globals
1509                       #:init (append (.init info)
1510                                      (list (lambda (functions globals ta t d data)
1511                                              (append
1512                                               (list-head data here)
1513                                               ;;(initzer->data info functions globals ta t d initzer)
1514                                               (initzer->data info functions globals ta t d `(p-expr (ident ,b)))
1515                                               (list-tail data (+ here 4))))))))
1516              ;;;(clone info #:globals (append globals (list (ident->global name type 1 0))))
1517              ))
1518
1519         ;; struct foo bar[2];
1520         ;; char arena[20000];
1521         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1522          (let ((type (ast->type type)))
1523            (if (.function info)
1524                (let* ((local (car (add-local locals name type -1)))
1525                       (count (string->number count))
1526                       (size (type->size info type))
1527                       (local (make-local name type -1 (+ (local:id local) (* count size))))
1528                       (locals (cons local locals))
1529                       (info (clone info #:locals locals)))
1530                  info)
1531                (let* ((globals (.globals info))
1532                       (count (cstring->number count))
1533                       (size (type->size info type))
1534                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1535                       (globals (append globals (list array))))
1536                  (clone info #:globals globals)))))
1537
1538         ;; char* a[10];
1539         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1540          (let ((type (ast->type type)))
1541            (if (.function info)
1542                (let* ((local (car (add-local locals name type -1)))
1543                       (count (string->number count))
1544                       (size (type->size info type))
1545                       (local (make-local name type 1 (+ (local:id local) (* count size))))
1546                       (locals (cons local locals))
1547                       (info (clone info #:locals locals)))
1548                  info)
1549                (let* ((globals (.globals info))
1550                       (count (cstring->number count))
1551                       (size (type->size info type))
1552                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1553                       (globals (append globals (list array))))
1554                  (clone info #:globals globals)))))
1555
1556         ;; struct foo bar;
1557         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1558          (if (.function info)
1559              (let* ((locals (add-local locals name `("struct" ,type) 1))
1560                     (info (clone info #:locals locals)))
1561                info)
1562              (let* ((size (type->size info (list "struct" type)))
1563                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1564                     (globals (append globals (list global)))
1565                     (info (clone info #:globals globals)))
1566                info)))
1567
1568         ;;struct scm *g_cells = (struct scm*)arena;
1569         ((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)))))))
1570          (if (.function info)
1571              (let* ((locals (add-local locals name `("struct" ,type) 1))
1572                     (info (clone info #:locals locals)))
1573                (append-text info (append ((ident->accu info) name)
1574                                          ((accu->ident info) value)))) ;; FIXME: deref?
1575              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1576                     (info (clone info #:globals globals)))
1577                (append-text info (append ((ident->accu info) name)
1578                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1579
1580
1581         ;; SCM tmp;
1582         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1583          (if (.function info)
1584              (clone info #:locals (add-local locals name type 0))
1585              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1586
1587         ;; SCM g_stack = 0;
1588         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1589          (let ((value (cstring->number value)))
1590            (if (.function info)
1591                (let* ((locals (add-local locals name type 0))
1592                       (info (clone info #:locals locals)))
1593                  (append-text info ((value->ident info) name value)))
1594                (let ((globals (append globals (list (ident->global name type 0 value)))))
1595                  (clone info #:globals globals)))))
1596
1597         ;; SCM g_stack = 0; // comment
1598         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1599          ((ast->info info) (list-head o (- (length o) 1))))
1600
1601         ;; SCM i = argc;
1602         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1603          (if (.function info)
1604              (let* ((locals (add-local locals name type 0))
1605                     (info (clone info #:locals locals)))
1606                (append-text info (append ((ident->accu info) local)
1607                                          ((accu->ident info) name))))
1608              (let* ((globals (append globals (list (ident->global name type 0 0))))
1609                     (info (clone info #:globals globals)))
1610                (append-text info (append ((ident->accu info) local)
1611                                          ((accu->ident info) name))))))
1612
1613         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1614         ((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))))
1615          (let* ((locals (add-local locals name type 1))
1616                 (info (clone info #:locals locals))
1617                 (empty (clone info #:text '()))
1618                 (accu ((expr->accu empty) initzer)))
1619            (clone info
1620                   #:text
1621                   (append text
1622                           (.text accu)
1623                           ((accu->ident info) name)
1624                           (list (lambda (f g ta t d)
1625                                   (append (i386:value->base ta)
1626                                           (i386:accu+base)))))
1627                   #:locals locals)))
1628
1629         ;; char *p = (char*)g_cells;
1630         ((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)))))))
1631          (if (.function info)
1632              (let* ((locals (add-local locals name type 1))
1633                     (info (clone info #:locals locals)))
1634                (append-text info (append ((ident->accu info) value)
1635                                          ((accu->ident info) name))))
1636              (let* ((globals (append globals (list (ident->global name type 1 0))))
1637                     (here (data-offset name globals))
1638                     (there (data-offset value globals)))
1639                (clone info
1640                       #:globals globals
1641                       #:init (append (.init info)
1642                                      (list (lambda (functions globals ta t d data)
1643                                              (append
1644                                               (list-head data here)
1645                                               ;;; FIXME: type
1646                                               ;;; char *x = arena;
1647                                               (int->bv32 (+ d (data-offset value globals)))
1648                                               ;;; char *y = x;
1649                                               ;;;(list-head (list-tail data there) 4)
1650                                               (list-tail data (+ here 4))))))))))
1651
1652         ;; char *p = g_cells;
1653         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1654          (let ((type (decl->type type)))
1655            (if (.function info)
1656                (let* ((locals (add-local locals name type  1))
1657                       (info (clone info #:locals locals)))
1658                  (append-text info (append ((ident->accu info) value)
1659                                            ((accu->ident info) name))))
1660                (let* ((globals (append globals (list (ident->global name type 1 0))))
1661                       (here (data-offset name globals)))
1662                  (clone info
1663                         #:globals globals
1664                         #:init (append (.init info)
1665                                        (list (lambda (functions globals ta t d data)
1666                                                (append
1667                                                 (list-head data here)
1668                                               ;;; FIXME: type
1669                                               ;;; char *x = arena;p
1670                                                 (int->bv32 (+ d (data-offset value globals)))
1671                                                 (list-tail data (+ here 4)))))))))))
1672
1673         ;; enum 
1674         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1675          (let ((type (enum->type name fields))
1676                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1677            (clone info
1678                   #:types (append (.types info) (list type))
1679                   #:constants (append constants (.constants info)))))
1680
1681         ;; struct
1682         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1683          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1684            (clone info #:types (append (.types info) (list type)))))
1685
1686         ;; char *p = &bla;
1687         ((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)))))))
1688          (let ((type (decl->type type)))
1689            (if (.function info)
1690                (let* ((locals (add-local locals name type 1))
1691                       (info (clone info #:locals locals)))
1692                  (append-text info (append ((ident-address->accu info) value)
1693                                            ((accu->ident info) name))))
1694                (error "TODO" o))))
1695
1696         ;; char **p = &bla;
1697         ((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)))))))
1698          (let ((type (decl->type type)))
1699            (if (.function info)
1700                (let* ((locals (add-local locals name type 2))
1701                       (info (clone info #:locals locals)))
1702                  (append-text info (append ((ident-address->accu info) value)
1703                                            ((accu->ident info) name))))
1704                (error "TODO" o))))
1705
1706         ;; char *p = bla[0];
1707         ((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)))))))
1708          (if (.function info)
1709              (let* ((locals (add-local locals name type 1))
1710                     (info (clone info #:locals locals))
1711                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1712                (append-text info ((accu->ident info) name)))
1713              (error "TODO" o)))
1714
1715         ;; char *p = *bla;
1716         ((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)))))))
1717          (if (.function info)
1718              (let* ((locals (add-local locals name type 2))
1719                     (info (clone info #:locals locals))
1720                     (local (assoc-ref (.locals info) name)))
1721                (append-text info (append ((ident->accu info) value)
1722                                          (wrap-as (i386:mem->accu))
1723                                          ((accu->ident info) name))))
1724              (error "TODO" o)))
1725
1726         ;; DECL
1727         ;; char *bla[] = {"a", "b"};
1728         ((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)))))
1729          (let* ((type (decl->type type))
1730                 (entries (map initzer->global initzers))
1731                 (entry-size 4)
1732                 (size (* (length entries) entry-size)))
1733            (if (.function info)
1734                (error "TODO: <type> x[] = {};" o)
1735                (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1736                       (globals (append globals entries (list global)))
1737                       (info (clone info #:globals globals))
1738                       (here (data-offset name globals)))
1739                  (clone info #:init
1740                         (append
1741                          (.init info)
1742                          (list (lambda (functions globals ta t d data)
1743                                  (append
1744                                   (list-head data here)
1745                                   (append-map
1746                                    (lambda (i)
1747                                      (initzer->data info functions globals ta t d i))
1748                                    initzers)
1749                                   (list-tail data (+ here size)))))))))))
1750
1751         ;;
1752         ;; struct f = {...};
1753         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1754          (let* ((type (decl->type type))
1755                 (fields (type->description info type))
1756                 (size (type->size info type))
1757                 (field-size 4))  ;; FIXME:4, not fixed
1758            (if (.function info)
1759                (let* ((globals (append globals (filter-map initzer->global initzers)))
1760                       (locals (let loop ((fields (cdr fields)) (locals locals))
1761                                 (if (null? fields) locals
1762                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1763                       (locals (add-local locals name type -1))
1764                       (info (clone info #:locals locals #:globals globals))
1765                       (empty (clone info #:text '())))
1766                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1767                    (if (null? fields) info
1768                        (let ((offset (* field-size (car fields)))
1769                              (initzer (car initzers)))
1770                          (loop (cdr fields) (cdr initzers)
1771                                (clone info #:text
1772                                       (append
1773                                        (.text info)
1774                                        ((ident->accu info) name)
1775                                        (wrap-as (append (i386:accu->base)))
1776                                        (.text ((expr->accu empty) initzer))
1777                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1778                (let* ((globals (append globals (filter-map initzer->global initzers)))
1779                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1780                       (globals (append globals (list global)))
1781                       (here (data-offset name globals))
1782                       (info (clone info #:globals globals))
1783                       (field-size 4))
1784                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1785                    (if (null? fields) info
1786                        (let ((offset (* field-size (car fields)))
1787                              (initzer (car initzers)))
1788                          (loop (cdr fields) (cdr initzers)
1789                                (clone info #:init
1790                                       (append
1791                                        (.init info)
1792                                        (list (lambda (functions globals ta t d data)
1793                                                (append
1794                                                 (list-head data (+ here offset))
1795                                                 (initzer->data info functions globals ta t d (car initzers))
1796                                                 (list-tail data (+ here offset field-size)))))))))))))))
1797
1798
1799         ;;char cc = g_cells[c].cdr;  ==> generic?
1800         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1801          (let ((type (decl->type type)))
1802            (if (.function info)
1803                (let* ((locals (add-local locals name type 0))
1804                       (info (clone info #:locals locals)))
1805                  (clone info #:text
1806                         (append (.text ((expr->accu info) initzer))
1807                                 ((accu->ident info) name))))
1808                (let* ((globals (append globals (list (ident->global name type 1 0))))
1809                       (here (data-offset name globals)))
1810                  (clone info
1811                         #:globals globals
1812                         #:init (append (.init info)
1813                                        (list (lambda (functions globals ta t d data)
1814                                                (append
1815                                                 (list-head data here)
1816                                                 (initzer->data info functions globals ta t d initzer)
1817                                                 (list-tail data (+ here 4)))))))))))
1818
1819
1820         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1821          info)
1822
1823         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1824          info)
1825
1826         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1827          (let ((types (.types info)))
1828            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1829
1830         ;; int foo ();
1831         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1832          info)
1833
1834         ;; void foo ();
1835         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1836          info)
1837
1838         ;; void foo (*);
1839         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1840          info)
1841
1842         ;; char const* itoa ();
1843         ((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))))))
1844          info)
1845
1846         ;; printf (char const* format, ...)
1847         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1848          info)
1849
1850         ;; int i = 0, j = 0;
1851         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
1852          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
1853            (if (null? inits) info
1854                (loop (cdr inits)
1855                      ((ast->info info)
1856                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
1857
1858         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1859          (format (current-error-port) "SKIP: typedef=~s\n" o)
1860          info)
1861
1862         ((decl (@ ,at))
1863          (format (current-error-port) "SKIP: at=~s\n" o)
1864          info)
1865
1866         ((decl . _) (error "ast->info: unsupported: " o))
1867
1868         ;; ...
1869         ((gt . _) ((expr->accu info) o))
1870         ((ge . _) ((expr->accu info) o))
1871         ((ne . _) ((expr->accu info) o))
1872         ((eq . _) ((expr->accu info) o))
1873         ((le . _) ((expr->accu info) o))
1874         ((lt . _) ((expr->accu info) o))
1875         ((lshift . _) ((expr->accu info) o))
1876         ((rshift . _) ((expr->accu info) o))
1877
1878         ;; EXPR
1879         ((expr-stmt ,expression)
1880          (let ((info ((expr->accu info) expression)))
1881            (append-text info (wrap-as (i386:accu-zero?)))))
1882
1883         ;; FIXME: why do we get (post-inc ...) here
1884         ;; (array-ref
1885         (_ (let ((info ((expr->accu info) o)))
1886              (append-text info (wrap-as (i386:accu-zero?)))))))))
1887
1888 (define (initzer->data info functions globals ta t d o)
1889   (pmatch o
1890     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1891     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1892     ((initzer (ref-to (p-expr (ident ,name))))
1893      (int->bv32 (+ ta (function-offset name functions))))
1894     ((initzer (p-expr (ident ,name)))
1895      (let ((value (assoc-ref (.constants info) name)))
1896        (int->bv32 value)))
1897     ((initzer (p-expr (string ,string)))
1898      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
1899     (_ (error "initzer->data: unsupported: " o))))
1900
1901 (define (.formals o)
1902   (pmatch o
1903     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1904     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1905     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
1906     (_ (error ".formals: " o))))
1907
1908 (define (formal->text n)
1909   (lambda (o i)
1910     ;;(i386:formal i n)
1911     '()
1912     ))
1913
1914 (define (formals->text o)
1915   (pmatch o
1916     ((param-list . ,formals)
1917      (let ((n (length formals)))
1918        (wrap-as (append (i386:function-preamble)
1919                         (append-map (formal->text n) formals (iota n))
1920                         (i386:function-locals)))))
1921     (_ (error "formals->text: unsupported: " o))))
1922
1923 (define (formal:ptr o)
1924   (pmatch o
1925     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
1926      0)
1927     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
1928      2)
1929     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
1930      1)
1931     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1932      1)
1933     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
1934      2)
1935     (_
1936      (stderr "formal:ptr[~a] => ~a\n" o 0)
1937      0)))
1938
1939 (define (formals->locals o)
1940   (pmatch o
1941     ((param-list . ,formals)
1942      (let ((n (length formals)))
1943        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
1944     (_ (error "formals->locals: unsupported: " o))))
1945
1946 (define (function->info info)
1947   (lambda (o)
1948     (let* ((name (.name o))
1949            (formals (.formals o))
1950            (text (formals->text formals))
1951            (locals (formals->locals formals)))
1952       (format (current-error-port) "compiling: ~a\n" name)
1953       (let loop ((statements (.statements o))
1954                  (info (clone info #:locals locals #:function (.name o) #:text text)))
1955         (if (null? statements) (clone info
1956                                       #:function #f
1957                                       #:functions (append (.functions info) (list (cons name (.text info)))))
1958             (let* ((statement (car statements)))
1959               (loop (cdr statements)
1960                     ((ast->info info) (car statements)))))))))
1961
1962 (define (ast-list->info info)
1963   (lambda (elements)
1964     (let loop ((elements elements) (info info))
1965       (if (null? elements) info
1966           (loop (cdr elements) ((ast->info info) (car elements)))))))
1967
1968 (define (c99-input->info)
1969   (let* ((info (make <info>
1970                  #:functions i386:libc
1971                  #:types i386:type-alist))
1972          (foo (stderr "compiling: mlibc\n"))
1973          (info (let loop ((info info) (libc libc))
1974                  (if (null? libc) info
1975                      (loop ((ast->info info) ((car libc))) (cdr libc)))))
1976          (foo (stderr "parsing: input\n"))
1977          (ast (c99-input->ast))
1978          (foo (stderr "compiling: input\n"))
1979          (info ((ast->info info) ast))
1980          (info ((ast->info info) (_start))))
1981     info))
1982
1983 (define (write-any x)
1984   (write-char (cond ((char? x) x)
1985                     ((and (number? x) (< (+ x 256) 0))
1986                      (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
1987                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
1988                     ((procedure? x)
1989                      (stderr "write-any: proc: ~a\n" x)
1990                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
1991                      (error "procedure: write-any:" x))
1992                     (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
1993
1994 (define (info->elf info)
1995   (display "dumping elf\n" (current-error-port))
1996   (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
1997
1998 (define (c99-input->elf)
1999   ((compose info->elf c99-input->info)))