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