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