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