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