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