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