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