4a3008b96c28cab021aa9d33ca9a16945248d8c9
[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                                          (append
746                                           (wrap-as (i386:base-address->accu-address))
747                                           (if (<= size 4) '()
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 (case->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 (p-expr (fixed ,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 (ast->info info)
1096   (lambda (o)
1097     (let ((globals (.globals info))
1098           (locals (.locals info))
1099           (constants (.constants info))
1100           (text (.text info)))
1101       (define (add-local locals name type pointer)
1102         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1103                        (1+ (local:id (cdar locals)))))
1104                (locals (cons (make-local name type pointer id) locals)))
1105           locals))
1106
1107       (pmatch o
1108         (((trans-unit . _) . _)
1109          ((ast-list->info info)  o))
1110         ((trans-unit . ,elements)
1111          ((ast-list->info info) elements))
1112         ((fctn-defn . _) ((function->info info) o))
1113         ((comment . _) info)
1114         ((cpp-stmt (define (name ,name) (repl ,value)))
1115          info)
1116
1117         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1118          info)
1119
1120         ((break)
1121          (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (text->list text)))))))
1122
1123         ;; FIXME: expr-stmt wrapper?
1124         (trans-unit info)
1125         ((expr-stmt) info)
1126
1127         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1128         
1129         ((if ,test ,body)
1130          (let* ((text-length (length text))
1131
1132                 (test-jump->info ((test->jump->info info) test))
1133                 (test+jump-info (test-jump->info 0))
1134                 (test-length (length (.text test+jump-info)))
1135
1136                 (body-info ((ast->info test+jump-info) body))
1137                 (text-body-info (.text body-info))
1138                 (body-text (list-tail text-body-info test-length))
1139                 (body-length (length (text->list body-text)))
1140
1141                 (text+test-text (.text (test-jump->info body-length)))
1142                 (test-text (list-tail text+test-text text-length)))
1143
1144            (clone info #:text
1145                   (append text
1146                           test-text
1147                           body-text)
1148                   #:globals (.globals body-info))))
1149
1150         ((if ,test ,then ,else)
1151          (let* ((text-length (length text))
1152
1153                 (test-jump->info ((test->jump->info info) test))
1154                 (test+jump-info (test-jump->info 0))
1155                 (test-length (length (.text test+jump-info)))
1156
1157                 (then-info ((ast->info test+jump-info) then))
1158                 (text-then-info (.text then-info))
1159                 (then-text (list-tail text-then-info test-length))
1160                 (then-jump-text (wrap-as (i386:Xjump 0)))
1161                 (then-jump-length (length (text->list then-jump-text)))
1162                 (then-length (+ (length (text->list then-text)) then-jump-length))
1163
1164                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1165                 (else-info ((ast->info then+jump-info) else))
1166                 (text-else-info (.text else-info))
1167                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1168                 (else-length (length (text->list else-text)))
1169
1170                 (text+test-text (.text (test-jump->info then-length)))
1171                 (test-text (list-tail text+test-text text-length))
1172                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1173
1174            (clone info #:text
1175                   (append text
1176                           test-text
1177                           then-text
1178                           then-jump-text
1179                           else-text)
1180                   #:globals (append (.globals then-info)
1181                                     (list-tail (.globals else-info) (length globals))))))
1182
1183         ;; Hmm?
1184         ((expr-stmt (cond-expr ,test ,then ,else))
1185          (let* ((text-length (length text))
1186
1187                 (test-jump->info ((test->jump->info info) test))
1188                 (test+jump-info (test-jump->info 0))
1189                 (test-length (length (.text test+jump-info)))
1190
1191                 (then-info ((ast->info test+jump-info) then))
1192                 (text-then-info (.text then-info))
1193                 (then-text (list-tail text-then-info test-length))
1194                 (then-length (length (text->list then-text)))
1195
1196                 (jump-text (wrap-as (i386:Xjump 0)))
1197                 (jump-length (length (text->list jump-text)))
1198
1199                 (test+then+jump-info
1200                  (clone then-info
1201                         #:text (append (.text then-info) jump-text)))
1202
1203                 (else-info ((ast->info test+then+jump-info) else))
1204                 (text-else-info (.text else-info))
1205                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1206                 (else-length (length (text->list else-text)))
1207
1208                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1209                 (test-text (list-tail text+test-text text-length))
1210                 (jump-text (wrap-as (i386:Xjump else-length))))
1211
1212            (clone info #:text
1213                   (append text
1214                           test-text
1215                           then-text
1216                           jump-text
1217                           else-text)
1218                   #:globals (.globals else-info))))
1219
1220         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1221          (let* ((expr ((expr->accu info) expr))
1222                 (empty (clone info #:text '()))
1223                 (case-infos (map (case->jump-info empty) cases))
1224                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1225                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1226                               (if (null? cases) info
1227                                   (let ((c-j ((case->jump-info info) (car cases))))
1228                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1229            cases-info))
1230
1231         ((for ,init ,test ,step ,body)
1232          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1233
1234                 (info ((ast->info info) init))
1235
1236                 (init-text (.text info))
1237                 (init-locals (.locals info))
1238                 (info (clone info #:text '()))
1239
1240                 (body-info ((ast->info info) body))
1241                 (body-text (.text body-info))
1242                 (body-length (length (text->list body-text)))
1243
1244                 (step-info ((expr->accu info) step))
1245                 (step-text (.text step-info))
1246                 (step-length (length (text->list step-text)))
1247
1248                 (test-jump->info ((test->jump->info info) test))
1249                 (test+jump-info (test-jump->info 0))
1250                 (test-length (length (text->list (.text test+jump-info))))
1251
1252                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1253
1254                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1255                 (jump-length (length (text->list jump-text)))
1256
1257                 (test-text (.text (test-jump->info jump-length))))
1258
1259            (clone info #:text
1260                   (append text
1261                           init-text
1262                           skip-body-text
1263                           body-text
1264                           step-text
1265                           test-text
1266                           jump-text)
1267                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1268                   #:locals locals)))
1269
1270         ((while ,test ,body)
1271          (let* ((skip-info (lambda (body-length test-length)
1272                              (clone info
1273                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1274                                     #:break (cons (+ (length (text->list text)) body-length test-length
1275                                                      (length (i386:Xjump 0)))
1276                                                   (.break info)))))
1277                 (text (.text (skip-info 0 0)))
1278                 (text-length (length text))
1279                 (body-info (lambda (body-length test-length)
1280                              ((ast->info (skip-info body-length test-length)) body)))
1281
1282                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1283                 (body-length (length (text->list body-text)))
1284
1285                 (empty (clone info #:text '()))
1286                 (test-jump->info ((test->jump->info empty) test))
1287                 (test+jump-info (test-jump->info 0))
1288                 (test-length (length (text->list (.text test+jump-info))))
1289
1290                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1291                 (jump-length (length (text->list jump-text)))
1292
1293                 (test-text (.text (test-jump->info jump-length)))
1294
1295                 (body-info (body-info body-length (length (text->list test-text)))))
1296
1297            (clone info #:text
1298                   (append
1299                    (.text body-info)
1300                    test-text
1301                    jump-text)
1302                   #:globals (.globals body-info))))
1303
1304         ((do-while ,body ,test)
1305          (let* ((text-length (length text))
1306
1307                 (body-info ((ast->info info) body))
1308                 (body-text (list-tail (.text body-info) text-length))
1309                 (body-length (length (text->list body-text)))
1310
1311                 (empty (clone info #:text '()))
1312                 (test-jump->info ((test->jump->info empty) test))
1313                 (test+jump-info (test-jump->info 0))
1314                 (test-length (length (text->list (.text test+jump-info))))
1315
1316                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1317                 (jump-length (length (text->list jump-text)))
1318
1319                 (test-text (.text (test-jump->info jump-length))))
1320            (clone info #:text
1321                   (append
1322                    (.text body-info)
1323                    test-text
1324                    jump-text)
1325                   #:globals (.globals body-info))))
1326
1327         ((labeled-stmt (ident ,label) ,statement)
1328          (let ((info (append-text info (list label))))
1329            ((ast->info info) statement)))
1330
1331         ((goto (ident ,label))
1332          (let* ((jump (lambda (n) (i386:XXjump n)))
1333                 (offset (+ (length (jump 0)) (length (text->list text)))))
1334            (append-text info (append 
1335                               (list (lambda (f g ta t d)
1336                                       (jump (- (label-offset (.function info) label f) offset))))))))
1337
1338         ((return ,expr)
1339          (let ((info ((expr->accu info) expr)))
1340            (append-text info (append  (wrap-as (i386:ret)))))) 
1341
1342         ;; DECL
1343
1344         ;; int i;
1345         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1346          (if (.function info)
1347              (clone info #:locals (add-local locals name type 0))
1348              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1349
1350         ;; int i = 0;
1351         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1352          (let ((value (cstring->number value)))
1353            (if (.function info)
1354                (let* ((locals (add-local locals name type 0))
1355                       (info (clone info #:locals locals)))
1356                  (append-text info ((value->ident info) name value)))
1357                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1358
1359         ;; char c = 'A';
1360         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1361          (if (not (.function info)) (error "ast->info: unsupported: " o))
1362          (let* ((locals (add-local locals name type 0))
1363                 (info (clone info #:locals locals))
1364                 (value (char->integer (car (string->list value)))))
1365            (append-text info ((value->ident info) name value))))
1366
1367         ;; int i = -1;
1368         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1369          (let ((value (- (cstring->number value))))
1370            (if (.function info)
1371                (let* ((locals (add-local locals name type 0))
1372                       (info (clone info #:locals locals)))
1373                  (append-text info ((value->ident info) name value)))
1374                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1375
1376         ;; int i = argc;
1377         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1378          (if (not (.function info)) (error "ast->info: unsupported: " o))
1379          (let* ((locals (add-local locals name type 0))
1380                 (info (clone info #:locals locals)))
1381            (append-text info (append ((ident->accu info) local)
1382                                      ((accu->ident info) name)))))
1383
1384         ;; char *p = "foo";
1385         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1386          (if (.function info)
1387              (let* ((locals (add-local locals name type 1))
1388                     (globals (append globals (list (string->global string))))
1389                     (info (clone info #:locals locals #:globals globals)))
1390                (append-text info (append
1391                                   (list (lambda (f g ta t d)
1392                                           (append
1393                                            (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1394                                   ((accu->ident info) name))))
1395              (let* ((global (string->global string))
1396                     (globals (append globals (list global)))
1397                     (size 4)
1398                     (global (make-global name type 1 (string->list (make-string size #\nul))))
1399                     (globals (append globals (list global)))
1400                     (info (clone info #:globals globals))
1401                     (here (data-offset name globals)))
1402                (clone info #:init
1403                       (append
1404                        (.init info)
1405                        (list (lambda (functions globals ta t d data)
1406                                (append
1407                                 (list-head data here)
1408                                 (initzer->data info functions globals ta t d `(initzer (p-expr (string ,string))))
1409                                 (list-tail data (+ here size))))))))))
1410         
1411         ;; char const *p;
1412         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1413          (if (.function info)
1414              (let* ((locals (add-local locals name type 1))
1415                     (info (clone info #:locals locals)))
1416                (append-text info (append (wrap-as (i386:value->accu 0))
1417                                          ((accu->ident info) name))))
1418              (let ((globals (append globals (list (ident->global name type 1 0)))))
1419                (clone info #:globals globals))))
1420
1421         ;; char *p;
1422         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1423          (if (.function info)
1424              (let* ((locals (add-local locals name type 1))
1425                     (info (clone info #:locals locals)))
1426                (append-text info (append (wrap-as (i386:value->accu 0))
1427                                          ((accu->ident info) name))))
1428              (let ((globals (append globals (list (ident->global name type 1 0)))))
1429                (clone info #:globals globals))))
1430
1431         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1432          (let ((value (cstring->number value)))
1433            (if (.function info)
1434                (let* ((locals (add-local locals name type 1))
1435                       (info (clone info #:locals locals)))
1436                  (append-text info (append (wrap-as (i386:value->accu value))
1437                                            ((accu->ident info) name))))
1438                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1439
1440         ;; char **p;
1441         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1442          (if (.function info)
1443              (let* ((locals (add-local locals name type 2))
1444                     (info (clone info #:locals locals)))
1445                (append-text info (append (wrap-as (i386:value->accu 0))
1446                                          ((accu->ident info) name))))
1447              (let ((globals (append globals (list (ident->global name type 2 0)))))
1448                (clone info #:globals globals))))
1449
1450         ;; char **p = 0;
1451         ;;((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)))))))
1452
1453         ;; char **p = g_environment;
1454         ((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
1455          (if (.function info)
1456              (let* ((locals (add-local locals name type 2))
1457                     (info (clone info #:locals locals)))
1458                (append-text info (append
1459                                   ((ident->accu info) b)
1460                                   ((accu->ident info) name))))
1461              (let* ((globals (append globals (list (ident->global name type 2 0))))
1462                     (here (data-offset name globals)))
1463                (clone info
1464                       #:globals globals
1465                       #:init (append (.init info)
1466                                      (list (lambda (functions globals ta t d data)
1467                                              (append
1468                                               (list-head data here)
1469                                               ;;(initzer->data info functions globals ta t d initzer)
1470                                               (initzer->data info functions globals ta t d `(p-expr (ident ,b)))
1471                                               (list-tail data (+ here 4))))))))
1472              ;;;(clone info #:globals (append globals (list (ident->global name type 1 0))))
1473              ))
1474
1475         ;; struct foo bar[2];
1476         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1477          (let ((type (ast->type `(struct-ref (ident ,type)))))
1478            (if (.function info)
1479                (let* ((local (car (add-local locals name type -1)))
1480                       (count (string->number count))
1481                       (size (type->size info type))
1482                       (local (make-local name type -1 (+ (local:id local) (* count size))))
1483                       (locals (cons local locals))
1484                       (info (clone info #:locals locals)))
1485                  info)
1486                (error "ast->info: unsupported global: " o))))
1487
1488         ;; char arena[20000];
1489         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1490          (let ((type (ast->type type)))
1491            (if (.function info) (error "ast->info: unsupported local: " o)
1492                (let* ((globals (.globals info))
1493                       (count (cstring->number count))
1494                       (size (type->size info type))
1495                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1496                       (globals (append globals (list array))))
1497                  (clone info #:globals globals)))))
1498
1499
1500         ;; struct foo bar;
1501         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1502          (if (.function info)
1503              (let* ((locals (add-local locals name `("struct" ,type) 1))
1504                     (info (clone info #:locals locals)))
1505                info)
1506              (let* ((size (type->size info (list "struct" type)))
1507                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1508                     (globals (append globals (list global)))
1509                     (info (clone info #:globals globals)))
1510                info)))
1511
1512         ;;struct scm *g_cells = (struct scm*)arena;
1513         ((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)))))))
1514          (if (.function info)
1515              (let* ((locals (add-local locals name `("struct" ,type) 1))
1516                     (info (clone info #:locals locals)))
1517                (append-text info (append ((ident->accu info) name)
1518                                          ((accu->ident info) value)))) ;; FIXME: deref?
1519              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1520                     (info (clone info #:globals globals)))
1521                (append-text info (append ((ident->accu info) name)
1522                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1523
1524
1525         ;; SCM tmp;
1526         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1527          (if (.function info)
1528              (clone info #:locals (add-local locals name type 0))
1529              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1530
1531         ;; SCM g_stack = 0;
1532         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1533          (let ((value (cstring->number value)))
1534            (if (.function info)
1535                (let* ((locals (add-local locals name type 0))
1536                       (info (clone info #:locals locals)))
1537                  (append-text info ((value->ident info) name value)))
1538                (let ((globals (append globals (list (ident->global name type 0 value)))))
1539                  (clone info #:globals globals)))))
1540
1541         ;; SCM g_stack = 0; // comment
1542         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1543          ((ast->info info) (list-head o (- (length o) 1))))
1544
1545         ;; SCM i = argc;
1546         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1547          (if (.function info)
1548              (let* ((locals (add-local locals name type 0))
1549                     (info (clone info #:locals locals)))
1550                (append-text info (append ((ident->accu info) local)
1551                                          ((accu->ident info) name))))
1552              (let* ((globals (append globals (list (ident->global name type 0 0))))
1553                     (info (clone info #:globals globals)))
1554                (append-text info (append ((ident->accu info) local)
1555                                          ((accu->ident info) name))))))
1556
1557         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1558         ((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))))
1559          (let* ((locals (add-local locals name type 1))
1560                 (info (clone info #:locals locals))
1561                 (empty (clone info #:text '()))
1562                 (accu ((expr->accu empty) initzer)))
1563            (clone info
1564                   #:text
1565                   (append text
1566                           (.text accu)
1567                           ((accu->ident info) name)
1568                           (list (lambda (f g ta t d)
1569                                   (append (i386:value->base ta)
1570                                           (i386:accu+base)))))
1571                   #:locals locals)))
1572
1573         ;; char *p = (char*)g_cells;
1574         ((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)))))))
1575          (if (.function info)
1576              (let* ((locals (add-local locals name type 1))
1577                     (info (clone info #:locals locals)))
1578                (append-text info (append ((ident->accu info) value)
1579                                          ((accu->ident info) name))))
1580              (let* ((globals (append globals (list (ident->global name type 1 0))))
1581                     (here (data-offset name globals))
1582                     (there (data-offset value globals)))
1583                (clone info
1584                       #:globals globals
1585                       #:init (append (.init info)
1586                                      (list (lambda (functions globals ta t d data)
1587                                              (append
1588                                               (list-head data here)
1589                                               ;;; FIXME: type
1590                                               ;;; char *x = arena;
1591                                               (int->bv32 (+ d (data-offset value globals)))
1592                                               ;;; char *y = x;
1593                                               ;;;(list-head (list-tail data there) 4)
1594                                               (list-tail data (+ here 4))))))))))
1595
1596         ;; char *p = g_cells;
1597         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1598          (let ((type (decl->type type)))
1599            (if (.function info)
1600                (let* ((locals (add-local locals name type  1))
1601                       (info (clone info #:locals locals)))
1602                  (append-text info (append ((ident->accu info) value)
1603                                            ((accu->ident info) name))))
1604                (let* ((globals (append globals (list (ident->global name type 1 0))))
1605                       (here (data-offset name globals)))
1606                  (clone info
1607                         #:globals globals
1608                         #:init (append (.init info)
1609                                        (list (lambda (functions globals ta t d data)
1610                                                (append
1611                                                 (list-head data here)
1612                                               ;;; FIXME: type
1613                                               ;;; char *x = arena;p
1614                                                 (int->bv32 (+ d (data-offset value globals)))
1615                                                 (list-tail data (+ here 4)))))))))))
1616
1617         ;; enum 
1618         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1619          (let ((type (enum->type name fields))
1620                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1621            (clone info
1622                   #:types (append (.types info) (list type))
1623                   #:constants (append constants (.constants info)))))
1624
1625         ;; struct
1626         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1627          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1628            (clone info #:types (append (.types info) (list type)))))
1629
1630         ;; char *p = &bla;
1631         ((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)))))))
1632          (let ((type (decl->type type)))
1633            (if (.function info)
1634                (let* ((locals (add-local locals name type 1))
1635                       (info (clone info #:locals locals)))
1636                  (append-text info (append ((ident-address->accu info) value)
1637                                            ((accu->ident info) name))))
1638                (error "TODO" o))))
1639
1640         ;; char **p = &bla;
1641         ((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)))))))
1642          (let ((type (decl->type type)))
1643            (if (.function info)
1644                (let* ((locals (add-local locals name type 2))
1645                       (info (clone info #:locals locals)))
1646                  (append-text info (append ((ident-address->accu info) value)
1647                                            ((accu->ident info) name))))
1648                (error "TODO" o))))
1649
1650         ;; char *p = bla[0];
1651         ((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)))))))
1652          (if (.function info)
1653              (let* ((locals (add-local locals name type 1))
1654                     (info (clone info #:locals locals))
1655                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1656                (append-text info ((accu->ident info) name)))
1657              (error "TODO" o)))
1658
1659         ;; char *p = *bla;
1660         ((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)))))))
1661          (if (.function info)
1662              (let* ((locals (add-local locals name type 2))
1663                     (info (clone info #:locals locals))
1664                     (local (assoc-ref (.locals info) name)))
1665                (append-text info (append ((ident->accu info) value)
1666                                          (wrap-as (i386:mem->accu))
1667                                          ((accu->ident info) name))))
1668              (error "TODO" o)))
1669
1670         ;; DECL
1671         ;; char *bla[] = {"a", "b"};
1672         ((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)))))
1673          (let* ((type (decl->type type))
1674                 (entries (map initzer->global initzers))
1675                 (entry-size 4)
1676                 (size (* (length entries) entry-size)))
1677            (if (.function info)
1678                (error "TODO: <type> x[] = {};" o)
1679                (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1680                       (globals (append globals entries (list global)))
1681                       (info (clone info #:globals globals))
1682                       (here (data-offset name globals)))
1683                  (clone info #:init
1684                         (append
1685                          (.init info)
1686                          (list (lambda (functions globals ta t d data)
1687                                  (append
1688                                   (list-head data here)
1689                                   (append-map
1690                                    (lambda (i)
1691                                      (initzer->data info functions globals ta t d i))
1692                                    initzers)
1693                                   (list-tail data (+ here size)))))))))))
1694
1695         ;;
1696         ;; struct f = {...};
1697         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1698          (let* ((type (decl->type type))
1699                 (fields (type->description info type))
1700                 (size (type->size info type))
1701                 (field-size 4))  ;; FIXME:4, not fixed
1702            (if (.function info)
1703                (let* ((globals (append globals (filter-map initzer->global initzers)))
1704                       (locals (let loop ((fields (cdr fields)) (locals locals))
1705                                 (if (null? fields) locals
1706                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1707                       (locals (add-local locals name type -1))
1708                       (info (clone info #:locals locals #:globals globals))
1709                       (empty (clone info #:text '())))
1710                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1711                    (if (null? fields) info
1712                        (let ((offset (* field-size (car fields)))
1713                              (initzer (car initzers)))
1714                          (loop (cdr fields) (cdr initzers)
1715                                (clone info #:text
1716                                       (append
1717                                        (.text info)
1718                                        ((ident->accu info) name)
1719                                        (wrap-as (append (i386:accu->base)))
1720                                        (.text ((expr->accu empty) initzer))
1721                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1722                (let* ((globals (append globals (filter-map initzer->global initzers)))
1723                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1724                       (globals (append globals (list global)))
1725                       (here (data-offset name globals))
1726                       (info (clone info #:globals globals))
1727                       (field-size 4))
1728                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1729                    (if (null? fields) info
1730                        (let ((offset (* field-size (car fields)))
1731                              (initzer (car initzers)))
1732                          (loop (cdr fields) (cdr initzers)
1733                                (clone info #:init
1734                                       (append
1735                                        (.init info)
1736                                        (list (lambda (functions globals ta t d data)
1737                                                (append
1738                                                 (list-head data (+ here offset))
1739                                                 (initzer->data info functions globals ta t d (car initzers))
1740                                                 (list-tail data (+ here offset field-size)))))))))))))))
1741
1742
1743         ;;char cc = g_cells[c].cdr;  ==> generic?
1744         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1745          (let ((type (decl->type type)))
1746            (if (.function info)
1747                (let* ((locals (add-local locals name type 0))
1748                       (info (clone info #:locals locals)))
1749                  (clone info #:text
1750                         (append (.text ((expr->accu info) initzer))
1751                                 ((accu->ident info) name))))
1752                (let* ((globals (append globals (list (ident->global name type 1 0))))
1753                       (here (data-offset name globals)))
1754                  (clone info
1755                         #:globals globals
1756                         #:init (append (.init info)
1757                                        (list (lambda (functions globals ta t d data)
1758                                                (append
1759                                                 (list-head data here)
1760                                                 (initzer->data info functions globals ta t d initzer)
1761                                                 (list-tail data (+ here 4)))))))))))
1762
1763
1764         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1765          info)
1766
1767         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1768          info)
1769
1770         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1771          (let ((types (.types info)))
1772            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1773
1774         ;; int foo ();
1775         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1776          info)
1777
1778         ;; void foo ();
1779         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1780          info)
1781
1782         ;; void foo (*);
1783         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1784          info)
1785
1786         ;; char const* itoa ();
1787         ((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))))))
1788          info)
1789
1790         ;; printf (char const* format, ...)
1791         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1792          info)
1793
1794         ;; int i = 0, j = 0;
1795         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
1796          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
1797            (if (null? inits) info
1798                (loop (cdr inits)
1799                      ((ast->info info)
1800                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
1801
1802         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1803          (format (current-error-port) "SKIP: typedef=~s\n" o)
1804          info)
1805
1806         ((decl (@ ,at))
1807          (format (current-error-port) "SKIP: at=~s\n" o)
1808          info)
1809
1810         ((decl . _) (error "ast->info: unsupported: " o))
1811
1812         ;; ...
1813         ((gt . _) ((expr->accu info) o))
1814         ((ge . _) ((expr->accu info) o))
1815         ((ne . _) ((expr->accu info) o))
1816         ((eq . _) ((expr->accu info) o))
1817         ((le . _) ((expr->accu info) o))
1818         ((lt . _) ((expr->accu info) o))
1819         ((lshift . _) ((expr->accu info) o))
1820         ((rshift . _) ((expr->accu info) o))
1821
1822         ;; EXPR
1823         ((expr-stmt ,expression)
1824          (let ((info ((expr->accu info) expression)))
1825            (append-text info (wrap-as (i386:accu-zero?)))))
1826
1827         ;; FIXME: why do we get (post-inc ...) here
1828         ;; (array-ref
1829         (_ (let ((info ((expr->accu info) o)))
1830              (append-text info (wrap-as (i386:accu-zero?)))))))))
1831
1832 (define (initzer->data info functions globals ta t d o)
1833   (pmatch o
1834     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1835     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1836     ((initzer (ref-to (p-expr (ident ,name))))
1837      (int->bv32 (+ ta (function-offset name functions))))
1838     ((initzer (p-expr (ident ,name)))
1839      (let ((value (assoc-ref (.constants info) name)))
1840        (int->bv32 value)))
1841     ((initzer (p-expr (string ,string)))
1842      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
1843     (_ (error "initzer->data: unsupported: " o))))
1844
1845 (define (.formals o)
1846   (pmatch o
1847     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1848     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1849     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
1850     (_ (error ".formals: " o))))
1851
1852 (define (formal->text n)
1853   (lambda (o i)
1854     ;;(i386:formal i n)
1855     '()
1856     ))
1857
1858 (define (formals->text o)
1859   (pmatch o
1860     ((param-list . ,formals)
1861      (let ((n (length formals)))
1862        (wrap-as (append (i386:function-preamble)
1863                         (append-map (formal->text n) formals (iota n))
1864                         (i386:function-locals)))))
1865     (_ (error "formals->text: unsupported: " o))))
1866
1867 (define (formal:ptr o)
1868   (pmatch o
1869     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
1870      0)
1871     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
1872      2)
1873     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
1874      1)
1875     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1876      1)
1877     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
1878      2)
1879     (_
1880      (stderr "formal:ptr[~a] => ~a\n" o 0)
1881      0)))
1882
1883 (define (formals->locals o)
1884   (pmatch o
1885     ((param-list . ,formals)
1886      (let ((n (length formals)))
1887        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
1888     (_ (error "formals->locals: unsupported: " o))))
1889
1890 (define (function->info info)
1891   (lambda (o)
1892     (let* ((name (.name o))
1893            (formals (.formals o))
1894            (text (formals->text formals))
1895            (locals (formals->locals formals)))
1896       (format (current-error-port) "compiling: ~a\n" name)
1897       (let loop ((statements (.statements o))
1898                  (info (clone info #:locals locals #:function (.name o) #:text text)))
1899         (if (null? statements) (clone info
1900                                       #:function #f
1901                                       #:functions (append (.functions info) (list (cons name (.text info)))))
1902             (let* ((statement (car statements)))
1903               (loop (cdr statements)
1904                     ((ast->info info) (car statements)))))))))
1905
1906 (define (ast-list->info info)
1907   (lambda (elements)
1908     (let loop ((elements elements) (info info))
1909       (if (null? elements) info
1910           (loop (cdr elements) ((ast->info info) (car elements)))))))
1911
1912 (define (c99-input->info)
1913   (let* ((info (make <info>
1914                  #:functions i386:libc
1915                  #:types i386:type-alist))
1916          (foo (stderr "compiling: mlibc\n"))
1917          (info (let loop ((info info) (libc libc))
1918                  (if (null? libc) info
1919                      (loop ((ast->info info) ((car libc))) (cdr libc)))))
1920          (foo (stderr "parsing: input\n"))
1921          (ast (c99-input->ast))
1922          (foo (stderr "compiling: input\n"))
1923          (info ((ast->info info) ast))
1924          (info ((ast->info info) (_start))))
1925     info))
1926
1927 (define (write-any x)
1928   (write-char (cond ((char? x) x)
1929                     ((and (number? x) (< (+ x 256) 0))
1930                      (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
1931                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
1932                     ((procedure? x)
1933                      (stderr "write-any: proc: ~a\n" x)
1934                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
1935                      (error "procedure: write-any:" x))
1936                     (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
1937
1938 (define (info->elf info)
1939   (display "dumping elf\n" (current-error-port))
1940   (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
1941
1942 (define (c99-input->elf)
1943   ((compose info->elf c99-input->info)))