0bc8258205b954b3396be147312a81c5c3e6e611
[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 optargs))))
39
40 (define (logf port string . rest)
41   (apply format (cons* port string rest))
42   (force-output port)
43   #t)
44
45 (define (stderr string . rest)
46   (apply logf (cons* (current-error-port) string rest)))
47
48 (define %datadir (if (string-prefix? "@DATADIR" "@DATADIR@") "" "@DATADIR@"))
49 (define %docdir (if (string-prefix? "@DOCDIR" "@DOCDIR@") "doc/" "@DOCDIR@"))
50 (define %moduledir "module/")
51 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
52 (define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
53
54 (define mes? (pair? (current-module)))
55
56 (define* (c99-input->ast #:key (defines '()) (includes '()))
57   (let ((include (if (equal? %prefix "") "libc/include" (string-append %prefix "/include"))))
58     (parse-c99
59      #:inc-dirs (append includes (cons* "." "libc" "src" "out" "out/src" include (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" 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         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1265          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1266                                    (append-text info (wrap-as (asm->hex arg0))))
1267              (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1268                (append-text info (wrap-as (i386:accu-zero?))))))
1269
1270         ((if ,test ,body)
1271          (let* ((text-length (length text))
1272
1273                 (test-jump->info ((test->jump->info info) test))
1274                 (test+jump-info (test-jump->info 0))
1275                 (test-length (length (.text test+jump-info)))
1276
1277                 (body-info ((ast->info test+jump-info) body))
1278                 (text-body-info (.text body-info))
1279                 (body-text (list-tail text-body-info test-length))
1280                 (body-length (length (object->list body-text)))
1281
1282                 (text+test-text (.text (test-jump->info body-length)))
1283                 (test-text (list-tail text+test-text text-length)))
1284
1285            (clone info #:text
1286                   (append text
1287                           test-text
1288                           body-text)
1289                   #:globals (.globals body-info))))
1290
1291         ((if ,test ,then ,else)
1292          (let* ((text-length (length text))
1293
1294                 (test-jump->info ((test->jump->info info) test))
1295                 (test+jump-info (test-jump->info 0))
1296                 (test-length (length (.text test+jump-info)))
1297
1298                 (then-info ((ast->info test+jump-info) then))
1299                 (text-then-info (.text then-info))
1300                 (then-text (list-tail text-then-info test-length))
1301                 (then-jump-text (wrap-as (i386:Xjump 0)))
1302                 (then-jump-length (length (object->list then-jump-text)))
1303                 (then-length (+ (length (object->list then-text)) then-jump-length))
1304
1305                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1306                 (else-info ((ast->info then+jump-info) else))
1307                 (text-else-info (.text else-info))
1308                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1309                 (else-length (length (object->list else-text)))
1310
1311                 (text+test-text (.text (test-jump->info then-length)))
1312                 (test-text (list-tail text+test-text text-length))
1313                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1314
1315            (clone info #:text
1316                   (append text
1317                           test-text
1318                           then-text
1319                           then-jump-text
1320                           else-text)
1321                   #:globals (append (.globals then-info)
1322                                     (list-tail (.globals else-info) (length globals))))))
1323
1324         ;; Hmm?
1325         ((expr-stmt (cond-expr ,test ,then ,else))
1326          (let* ((text-length (length text))
1327
1328                 (test-jump->info ((test->jump->info info) test))
1329                 (test+jump-info (test-jump->info 0))
1330                 (test-length (length (.text test+jump-info)))
1331
1332                 (then-info ((ast->info test+jump-info) then))
1333                 (text-then-info (.text then-info))
1334                 (then-text (list-tail text-then-info test-length))
1335                 (then-length (length (object->list then-text)))
1336
1337                 (jump-text (wrap-as (i386:Xjump 0)))
1338                 (jump-length (length (object->list jump-text)))
1339
1340                 (test+then+jump-info
1341                  (clone then-info
1342                         #:text (append (.text then-info) jump-text)))
1343
1344                 (else-info ((ast->info test+then+jump-info) else))
1345                 (text-else-info (.text else-info))
1346                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1347                 (else-length (length (object->list else-text)))
1348
1349                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1350                 (test-text (list-tail text+test-text text-length))
1351                 (jump-text (wrap-as (i386:Xjump else-length))))
1352
1353            (clone info #:text
1354                   (append text
1355                           test-text
1356                           then-text
1357                           jump-text
1358                           else-text)
1359                   #:globals (.globals else-info))))
1360
1361         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1362          (let* ((clauses (statements->clauses statements))
1363                 (expr ((expr->accu info) expr))
1364                 (empty (clone info #:text '()))
1365                 (clause-infos (map (clause->jump-info empty) clauses))
1366                 (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
1367                 (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
1368                               (if (null? clauses) info
1369                                   (let ((c-j ((clause->jump-info info) (car clauses))))
1370                                     (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1371            clauses-info))
1372
1373         ((for ,init ,test ,step ,body)
1374          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1375
1376                 (info ((ast->info info) init))
1377
1378                 (init-text (.text info))
1379                 (init-locals (.locals info))
1380                 (info (clone info #:text '()))
1381
1382                 (body-info ((ast->info info) body))
1383                 (body-text (.text body-info))
1384                 (body-length (length (object->list body-text)))
1385
1386                 (step-info ((expr->accu info) step))
1387                 (step-text (.text step-info))
1388                 (step-length (length (object->list step-text)))
1389
1390                 (test-jump->info ((test->jump->info info) test))
1391                 (test+jump-info (test-jump->info 0))
1392                 (test-length (length (object->list (.text test+jump-info))))
1393
1394                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1395
1396                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1397                 (jump-length (length (object->list jump-text)))
1398
1399                 (test-text (.text (test-jump->info jump-length))))
1400
1401            (clone info #:text
1402                   (append text
1403                           init-text
1404                           skip-body-text
1405                           body-text
1406                           step-text
1407                           test-text
1408                           jump-text)
1409                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1410                   #:locals locals)))
1411
1412         ((while ,test ,body)
1413          (let* ((skip-info (lambda (body-length test-length)
1414                              (clone info
1415                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1416                                     #:break (cons (+ (length (object->list text)) body-length test-length
1417                                                      (length (i386:Xjump 0)))
1418                                                   (.break info)))))
1419                 (text (.text (skip-info 0 0)))
1420                 (text-length (length text))
1421                 (body-info (lambda (body-length test-length)
1422                              ((ast->info (skip-info body-length test-length)) body)))
1423
1424                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1425                 (body-length (length (object->list body-text)))
1426
1427                 (empty (clone info #:text '()))
1428                 (test-jump->info ((test->jump->info empty) test))
1429                 (test+jump-info (test-jump->info 0))
1430                 (test-length (length (object->list (.text test+jump-info))))
1431
1432                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1433                 (jump-length (length (object->list jump-text)))
1434
1435                 (test-text (.text (test-jump->info jump-length)))
1436
1437                 (body-info (body-info body-length (length (object->list test-text)))))
1438
1439            (clone info #:text
1440                   (append
1441                    (.text body-info)
1442                    test-text
1443                    jump-text)
1444                   #:globals (.globals body-info))))
1445
1446         ((do-while ,body ,test)
1447          (let* ((text-length (length text))
1448
1449                 (body-info ((ast->info info) body))
1450                 (body-text (list-tail (.text body-info) text-length))
1451                 (body-length (length (object->list body-text)))
1452
1453                 (empty (clone info #:text '()))
1454                 (test-jump->info ((test->jump->info empty) test))
1455                 (test+jump-info (test-jump->info 0))
1456                 (test-length (length (object->list (.text test+jump-info))))
1457
1458                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1459                 (jump-length (length (object->list jump-text)))
1460
1461                 (test-text (.text (test-jump->info jump-length))))
1462            (clone info #:text
1463                   (append
1464                    (.text body-info)
1465                    test-text
1466                    jump-text)
1467                   #:globals (.globals body-info))))
1468
1469         ((labeled-stmt (ident ,label) ,statement)
1470          (let ((info (append-text info (list label))))
1471            ((ast->info info) statement)))
1472
1473         ((goto (ident ,label))
1474          (let* ((jump (lambda (n) (i386:XXjump n)))
1475                 (offset (+ (length (jump 0)) (length (object->list text)))))
1476            (append-text info (append 
1477                               (list `(lambda (f g ta t d)
1478                                       (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
1479
1480         ((return ,expr)
1481          (let ((info ((expr->accu info) expr)))
1482            (append-text info (append (wrap-as (i386:ret))))))
1483
1484         ;; DECL
1485
1486         ;; int i;
1487         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1488          (if (.function info)
1489              (clone info #:locals (add-local locals name type 0))
1490              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1491
1492         ;; enum e i;
1493         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1494          (let ((type "int")) ;; FIXME
1495            (if (.function info)
1496                (clone info #:locals (add-local locals name type 0))
1497                (clone info #:globals (append globals (list (ident->global name type 0 0)))))))
1498
1499         ;; int i = 0;
1500         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1501          (let ((value (cstring->number value)))
1502            (if (.function info)
1503                (let* ((locals (add-local locals name type 0))
1504                       (info (clone info #:locals locals)))
1505                  (append-text info ((value->ident info) name value)))
1506                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1507
1508         ;; char c = 'A';
1509         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1510          (if (not (.function info)) (error "ast->info: unsupported: " o))
1511          (let* ((locals (add-local locals name type 0))
1512                 (info (clone info #:locals locals))
1513                 (value (char->integer (car (string->list value)))))
1514            (append-text info ((value->ident info) name value))))
1515
1516         ;; int i = -1;
1517         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1518          (let ((value (- (cstring->number value))))
1519            (if (.function info)
1520                (let* ((locals (add-local locals name type 0))
1521                       (info (clone info #:locals locals)))
1522                  (append-text info ((value->ident info) name value)))
1523                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1524
1525         ;; int i = argc;
1526         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1527          (if (not (.function info)) (error "ast->info: unsupported: " o))
1528          (let* ((locals (add-local locals name type 0))
1529                 (info (clone info #:locals locals)))
1530            (append-text info (append ((ident->accu info) local)
1531                                      ((accu->ident info) name)))))
1532
1533         ;; char *p = "foo";
1534         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1535          (if (.function info)
1536              (let* ((locals (add-local locals name type 1))
1537                     (globals (append globals (list (string->global string))))
1538                     (info (clone info #:locals locals #:globals globals)))
1539                (append-text info (append
1540                                   (list `(lambda (f g ta t d)
1541                                           (append
1542                                            (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
1543                                   ((accu->ident info) name))))
1544              (let* ((global (string->global string))
1545                     (globals (append globals (list global)))
1546                     (size 4)
1547                     (global (make-global name type 1 (string->list (make-string size #\nul))))
1548                     (globals (append globals (list global)))
1549                     (info (clone info #:globals globals)))
1550                (clone info #:init
1551                       (append
1552                        (.init info)
1553                        (list
1554                         `(lambda (f g ta t d data)
1555                            (let (((here (data-offset ,name g))))
1556                              (append
1557                               (list-head data here)
1558                               (initzer->data f g ta t d '(initzer (p-expr (string ,string))))
1559                               (list-tail data (+ here ,size)))))))))))
1560         
1561         ;; char const *p;
1562         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1563          (if (.function info)
1564              (let* ((locals (add-local locals name type 1))
1565                     (info (clone info #:locals locals)))
1566                (append-text info (append (wrap-as (i386:value->accu 0))
1567                                          ((accu->ident info) name))))
1568              (let ((globals (append globals (list (ident->global name type 1 0)))))
1569                (clone info #:globals globals))))
1570
1571         ;; char *p;
1572         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1573          (if (.function info)
1574              (let* ((locals (add-local locals name type 1))
1575                     (info (clone info #:locals locals)))
1576                (append-text info (append (wrap-as (i386:value->accu 0))
1577                                          ((accu->ident info) name))))
1578              (let ((globals (append globals (list (ident->global name type 1 0)))))
1579                (clone info #:globals globals))))
1580
1581         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1582          (let ((value (cstring->number value)))
1583            (if (.function info)
1584                (let* ((locals (add-local locals name type 1))
1585                       (info (clone info #:locals locals)))
1586                  (append-text info (append (wrap-as (i386:value->accu value))
1587                                            ((accu->ident info) name))))
1588                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1589
1590         ;; char **p;
1591         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1592          (if (.function info)
1593              (let* ((locals (add-local locals name type 2))
1594                     (info (clone info #:locals locals)))
1595                (append-text info (append (wrap-as (i386:value->accu 0))
1596                                          ((accu->ident info) name))))
1597              (let ((globals (append globals (list (ident->global name type 2 0)))))
1598                (clone info #:globals globals))))
1599
1600         ;; char **p = 0;
1601         ;;((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)))))))
1602
1603         ;; char **p = g_environment;
1604         ((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
1605          (if (.function info)
1606              (let* ((locals (add-local locals name type 2))
1607                     (info (clone info #:locals locals)))
1608                (append-text info (append
1609                                   ((ident->accu info) b)
1610                                   ((accu->ident info) name))))
1611              (let* ((globals (append globals (list (ident->global name type 2 0))))
1612                     (value (assoc-ref constants b)))
1613                (clone info
1614                       #:globals globals
1615                       #:init (append (.init info)
1616                                      (list
1617                                       `(lambda (f g ta t d data)
1618                                          (let ((here (data-offset ,name g)))
1619                                            (append
1620                                             (list-head data here)
1621                                             (initzer->data f g ta t d '(p-expr (fixed ,value)))
1622                                             (list-tail data (+ here 4)))))))))))
1623
1624         ;; struct foo bar[2];
1625         ;; char arena[20000];
1626         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1627          (let ((type (ast->type type)))
1628            (if (.function info)
1629                (let* ((local (car (add-local locals name type -1)))
1630                       (count (string->number count))
1631                       (size (type->size info type))
1632                       (local (make-local name type -1 (+ (local:id local) (* count size))))
1633                       (locals (cons local locals))
1634                       (info (clone info #:locals locals)))
1635                  info)
1636                (let* ((globals (.globals info))
1637                       (count (cstring->number count))
1638                       (size (type->size info type))
1639                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1640                       (globals (append globals (list array))))
1641                  (clone info #:globals globals)))))
1642
1643         ;; char* a[10];
1644         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1645          (let ((type (ast->type type)))
1646            (if (.function info)
1647                (let* ((local (car (add-local locals name type -1)))
1648                       (count (string->number count))
1649                       (size (type->size info type))
1650                       (local (make-local name type 1 (+ (local:id local) (* count size))))
1651                       (locals (cons local locals))
1652                       (info (clone info #:locals locals)))
1653                  info)
1654                (let* ((globals (.globals info))
1655                       (count (cstring->number count))
1656                       (size (type->size info type))
1657                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1658                       (globals (append globals (list array))))
1659                  (clone info #:globals globals)))))
1660
1661         ;; struct foo bar;
1662         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1663          (if (.function info)
1664              (let* ((locals (add-local locals name `("struct" ,type) 1))
1665                     (info (clone info #:locals locals)))
1666                info)
1667              (let* ((size (type->size info (list "struct" type)))
1668                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1669                     (globals (append globals (list global)))
1670                     (info (clone info #:globals globals)))
1671                info)))
1672
1673         ;;struct scm *g_cells = (struct scm*)arena;
1674         ((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)))))))
1675          (if (.function info)
1676              (let* ((locals (add-local locals name `("struct" ,type) 1))
1677                     (info (clone info #:locals locals)))
1678                (append-text info (append ((ident->accu info) name)
1679                                          ((accu->ident info) value)))) ;; FIXME: deref?
1680              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1681                     (info (clone info #:globals globals)))
1682                (append-text info (append ((ident->accu info) name)
1683                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1684
1685
1686         ;; SCM tmp;
1687         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1688          (if (.function info)
1689              (clone info #:locals (add-local locals name type 0))
1690              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1691
1692         ;; SCM g_stack = 0;
1693         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1694          (let ((value (cstring->number value)))
1695            (if (.function info)
1696                (let* ((locals (add-local locals name type 0))
1697                       (info (clone info #:locals locals)))
1698                  (append-text info ((value->ident info) name value)))
1699                (let ((globals (append globals (list (ident->global name type 0 value)))))
1700                  (clone info #:globals globals)))))
1701
1702         ;; SCM g_stack = 0; // comment
1703         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1704          ((ast->info info) (list-head o (- (length o) 1))))
1705
1706         ;; SCM i = argc;
1707         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1708          (if (.function info)
1709              (let* ((locals (add-local locals name type 0))
1710                     (info (clone info #:locals locals)))
1711                (append-text info (append ((ident->accu info) local)
1712                                          ((accu->ident info) name))))
1713              (let* ((globals (append globals (list (ident->global name type 0 0))))
1714                     (info (clone info #:globals globals)))
1715                (append-text info (append ((ident->accu info) local)
1716                                          ((accu->ident info) name))))))
1717
1718         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1719         ((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))))
1720          (let* ((locals (add-local locals name type 1))
1721                 (info (clone info #:locals locals))
1722                 (empty (clone info #:text '()))
1723                 (accu ((expr->accu empty) initzer)))
1724            (clone info
1725                   #:text
1726                   (append text
1727                           (.text accu)
1728                           ((accu->ident info) name)
1729                           (list `(lambda (f g ta t d)
1730                                   (append (i386:value->base ta)
1731                                           (i386:accu+base)))))
1732                   #:locals locals)))
1733
1734         ;; char *p = (char*)g_cells;
1735         ((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)))))))
1736          (if (.function info)
1737              (let* ((locals (add-local locals name type 1))
1738                     (info (clone info #:locals locals)))
1739                (append-text info (append ((ident->accu info) value)
1740                                          ((accu->ident info) name))))
1741              (let* ((globals (append globals (list (ident->global name type 1 0)))))
1742                (clone info
1743                       #:globals globals
1744                       #:init (append (.init info)
1745                                      (list
1746                                       `(lambda (f g ta t d data)
1747                                          (let ((here (data-offset ,name g))
1748                                                (there (data-offset ,value g)))
1749                                            (append
1750                                             (list-head data here)
1751                                             ;; FIXME: type
1752                                             ;; char *x = arena;
1753                                             (int->bv32 (+ d (data-offset ,value g)))
1754                                             ;; char *y = x;
1755                                             ;;(list-head (list-tail data there) 4)
1756                                             (list-tail data (+ here 4)))))))))))
1757
1758         ;; char *p = g_cells;
1759         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1760          (let ((type (decl->type type)))
1761            (if (.function info)
1762                (let* ((locals (add-local locals name type  1))
1763                       (info (clone info #:locals locals)))
1764                  (append-text info (append ((ident->accu info) value)
1765                                            ((accu->ident info) name))))
1766                (let* ((globals (append globals (list (ident->global name type 1 0)))))
1767                  (clone info
1768                         #:globals globals
1769                         #:init (append (.init info)
1770                                        (list `(lambda (f g ta t d data)
1771                                                 (let ((here (data-offset ,name g)))
1772                                                   (append
1773                                                    (list-head data here)
1774                                                    ;; FIXME: type
1775                                                    ;; char *x = arena;p
1776                                                    (int->bv32 (+ d (data-offset ,value g)))
1777                                                    (list-tail data (+ here 4))))))))))))
1778
1779         ;; enum foo { };
1780         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1781          (let ((type (enum->type name fields))
1782                (constants (enum-def-list->constants constants fields)))
1783            (clone info
1784                   #:types (append (.types info) (list type))
1785                   #:constants (append constants (.constants info)))))
1786
1787         ;; enum {};
1788         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1789          (let ((constants (enum-def-list->constants constants fields)))
1790            (clone info
1791                   #:constants (append constants (.constants info)))))
1792
1793         ;; struct
1794         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1795          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1796            (clone info #:types (append (.types info) (list type)))))
1797
1798         ;; struct foo {} bar;
1799         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1800                (init-declr-list (init-declr (ident ,name))))
1801          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1802            ((ast->info info)
1803             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1804
1805         ;; struct foo* bar = expr;
1806          ((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)))))))
1807          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1808                                      (info (clone info #:locals locals)))
1809                  (append-text info (append ((ident-address->accu info) value)
1810                                            ((accu->ident info) name))))
1811              (error "ast->info: unsupported global:" o)))
1812
1813         ;; char *p = &bla;
1814         ((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)))))))
1815          (let ((type (decl->type type)))
1816            (if (.function info)
1817                (let* ((locals (add-local locals name type 1))
1818                       (info (clone info #:locals locals)))
1819                  (append-text info (append ((ident-address->accu info) value)
1820                                            ((accu->ident info) name))))
1821                (error "TODO" o))))
1822
1823         ;; char **p = &bla;
1824         ((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)))))))
1825          (let ((type (decl->type type)))
1826            (if (.function info)
1827                (let* ((locals (add-local locals name type 2))
1828                       (info (clone info #:locals locals)))
1829                  (append-text info (append ((ident-address->accu info) value)
1830                                            ((accu->ident info) name))))
1831                (error "TODO" o))))
1832
1833         ;; char *p = bla[0];
1834         ((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)))))))
1835          (if (.function info)
1836              (let* ((locals (add-local locals name type 1))
1837                     (info (clone info #:locals locals))
1838                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1839                (append-text info ((accu->ident info) name)))
1840              (error "TODO" o)))
1841
1842         ;; char *foo = &bar[0];
1843         ((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))))))))
1844          (if (.function info)
1845              (let* ((locals (add-local locals name type 1))
1846                     (info (clone info #:locals locals))
1847                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1848                (append-text info ((accu->ident info) name)))
1849              (error "TODO" o)))
1850
1851         ;; char *p = *bla;
1852         ((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)))))))
1853          (if (.function info)
1854              (let* ((locals (add-local locals name type 1))
1855                     (info (clone info #:locals locals))
1856                     (local (assoc-ref (.locals info) name)))
1857                (append-text info (append ((ident->accu info) value)
1858                                          (wrap-as (i386:mem->accu))
1859                                          ((accu->ident info) name))))
1860              (error "TODO" o)))
1861
1862         ;; DECL
1863         ;; char *bla[] = {"a", "b"};
1864         ((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)))))
1865          (let* ((type (decl->type type))
1866                 (entries (map initzer->global initzers))
1867                 (entry-size 4)
1868                 (size (* (length entries) entry-size))
1869                 (initzers (map (initzer->non-const info) initzers)))
1870            (if (.function info)
1871                (error "TODO: <type> x[] = {};" o)
1872                (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1873                       (globals (append globals entries (list global)))
1874                       (info (clone info #:globals globals)))
1875                  (clone info #:init
1876                         (append
1877                          (.init info)
1878                          (list
1879                           `(lambda (f g ta t d data)
1880                              (let ((here (data-offset ,name g)))
1881                                (append
1882                                 (list-head data here)
1883                                 (append-map
1884                                  (lambda (i)
1885                                    (initzer->data f g ta t d i))
1886                                  ',initzers)
1887                                 (list-tail data (+ here ,size))))))))))))
1888
1889         ;;
1890         ;; struct f = {...};
1891         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1892          (let* ((type (decl->type type))
1893                 (fields (type->description info type))
1894                 (size (type->size info type))
1895                 (field-size 4)  ;; FIXME:4, not fixed
1896                 (initzers (map (initzer->non-const info) initzers)))
1897            (if (.function info)
1898                (let* ((globals (append globals (filter-map initzer->global initzers)))
1899                       (locals (let loop ((fields (cdr fields)) (locals locals))
1900                                 (if (null? fields) locals
1901                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1902                       (locals (add-local locals name type -1))
1903                       (info (clone info #:locals locals #:globals globals))
1904                       (empty (clone info #:text '())))
1905                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1906                    (if (null? fields) info
1907                        (let ((offset (* field-size (car fields)))
1908                              (initzer (car initzers)))
1909                          (loop (cdr fields) (cdr initzers)
1910                                (clone info #:text
1911                                       (append
1912                                        (.text info)
1913                                        ((ident->accu info) name)
1914                                        (wrap-as (append (i386:accu->base)))
1915                                        (.text ((expr->accu empty) initzer))
1916                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1917                (let* ((globals (append globals (filter-map initzer->global initzers)))
1918                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1919                       (globals (append globals (list global)))
1920                       (info (clone info #:globals globals))
1921                       (field-size 4))
1922                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1923                    (if (null? fields) info
1924                        (let ((offset (* field-size (car fields)))
1925                              (initzer (car initzers)))
1926                          (loop (cdr fields) (cdr initzers)
1927                                (clone info #:init
1928                                       (append
1929                                        (.init info)
1930                                        (list
1931                                         `(lambda (f g ta t d data)
1932                                            (let ((here (data-offset ,name g)))
1933                                              (append
1934                                               (list-head data (+ here ,offset))
1935                                               (initzer->data f g ta t d ',(car initzers))
1936                                               (list-tail data (+ here ,offset ,field-size))))))))))))))))
1937
1938
1939         ;;char cc = g_cells[c].cdr;  ==> generic?
1940         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1941          (let ((type (decl->type type))
1942                (initzer ((initzer->non-const info) initzer)))
1943            (if (.function info)
1944                (let* ((locals (add-local locals name type 0))
1945                       (info (clone info #:locals locals)))
1946                  (clone info #:text
1947                         (append (.text ((expr->accu info) initzer))
1948                                 ((accu->ident info) name))))
1949                (let* ((globals (append globals (list (ident->global name type 1 0)))))
1950                  (clone info
1951                         #:globals globals
1952                         #:init (append (.init info)
1953                                        (list
1954                                         `(lambda (f g ta t d data)
1955                                            (let ((here (data-offset ,name g)))
1956                                              (append
1957                                               (list-head data here)
1958                                               (initzer->data f g ta t d ',initzer)
1959                                               (list-tail data (+ here 4))))))))))))
1960
1961
1962         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1963          (declare name))
1964
1965         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1966          (declare name))
1967
1968         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1969          (let ((types (.types info)))
1970            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1971
1972         ;; int foo ();
1973         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1974          (declare name))
1975
1976         ;; void foo ();
1977         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1978          (declare name))
1979
1980         ;; void foo (*);
1981         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1982          (declare name))
1983
1984         ;; char const* itoa ();
1985         ((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))))))
1986          (declare name))
1987
1988         ;; char *strcpy ();
1989         ((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))))))
1990          (declare name))
1991
1992         ;; printf (char const* format, ...)
1993         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1994          info)
1995
1996         ;; int i = 0, j = 0;
1997         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
1998          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
1999            (if (null? inits) info
2000                (loop (cdr inits)
2001                      ((ast->info info)
2002                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2003
2004         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2005          (format (current-error-port) "SKIP: typedef=~s\n" o)
2006          info)
2007
2008         ((decl (@ ,at))
2009          (format (current-error-port) "SKIP: at=~s\n" o)
2010          info)
2011
2012         ((decl . _) (error "ast->info: unsupported: " o))
2013
2014         ;; ...
2015         ((gt . _) ((expr->accu info) o))
2016         ((ge . _) ((expr->accu info) o))
2017         ((ne . _) ((expr->accu info) o))
2018         ((eq . _) ((expr->accu info) o))
2019         ((le . _) ((expr->accu info) o))
2020         ((lt . _) ((expr->accu info) o))
2021         ((lshift . _) ((expr->accu info) o))
2022         ((rshift . _) ((expr->accu info) o))
2023
2024         ;; EXPR
2025         ((expr-stmt ,expression)
2026          (let ((info ((expr->accu info) expression)))
2027            (append-text info (wrap-as (i386:accu-zero?)))))
2028
2029         ;; FIXME: why do we get (post-inc ...) here
2030         ;; (array-ref
2031         (_ (let ((info ((expr->accu info) o)))
2032              (append-text info (wrap-as (i386:accu-zero?)))))))))
2033
2034 (define (enum-def-list->constants constants fields)
2035   (let loop ((fields fields) (i 0) (constants constants))
2036     (if (null? fields) constants
2037         (let* ((field (car fields))
2038                (name (pmatch field
2039                        ((enum-defn (ident ,name) . _) name)))
2040                (i (pmatch field
2041                     ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
2042                     ((enum-defn ,name) i))))
2043           (loop (cdr fields)
2044                 (1+ i)
2045                 (append constants (list (ident->constant name i))))))))
2046
2047 (define (initzer->non-const info)
2048   (lambda (o)
2049     (pmatch o
2050       ((initzer (p-expr (ident ,name)))
2051        (let ((value (assoc-ref (.constants info) name)))
2052          `(initzer (p-expr (fixed ,(number->string value))))))
2053       (_ o))))
2054
2055 (define (initzer->data f g ta t d o)
2056   (pmatch o
2057     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2058     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2059     ((initzer (ref-to (p-expr (ident ,name))))
2060      (int->bv32 (+ ta (function-offset name f))))
2061     ((initzer (p-expr (string ,string)))
2062      (int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
2063     (_ (error "initzer->data: unsupported: " o))))
2064
2065 (define (.formals o)
2066   (pmatch o
2067     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2068     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2069     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2070     (_ (error ".formals: " o))))
2071
2072 (define (formal->text n)
2073   (lambda (o i)
2074     ;;(i386:formal i n)
2075     '()
2076     ))
2077
2078 (define (formals->text o)
2079   (pmatch o
2080     ((param-list . ,formals)
2081      (let ((n (length formals)))
2082        (wrap-as (append (i386:function-preamble)
2083                         (append-map (formal->text n) formals (iota n))
2084                         (i386:function-locals)))))
2085     (_ (error "formals->text: unsupported: " o))))
2086
2087 (define (formal:ptr o)
2088   (pmatch o
2089     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2090      0)
2091     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2092      2)
2093     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2094      1)
2095     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2096      1)
2097     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2098      2)
2099     (_
2100      (stderr "formal:ptr[~a] => ~a\n" o 0)
2101      0)))
2102
2103 (define (formals->locals o)
2104   (pmatch o
2105     ((param-list . ,formals)
2106      (let ((n (length formals)))
2107        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2108     (_ (error "formals->locals: unsupported: " o))))
2109
2110 (define (function->info info)
2111   (lambda (o)
2112     (define (assert-return text)
2113       (let ((return (wrap-as (i386:ret))))
2114         (if (equal? (list-tail text (- (length text) (length return))) return) text
2115             (append text return))))
2116     (let* ((name (.name o))
2117            (formals (.formals o))
2118            (text (formals->text formals))
2119            (locals (formals->locals formals)))
2120       (format (current-error-port) "compiling: ~a\n" name)
2121       (let loop ((statements (.statements o))
2122                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2123         (if (null? statements) (clone info
2124                                       #:function #f
2125                                       #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2126             (let* ((statement (car statements)))
2127               (loop (cdr statements)
2128                     ((ast->info info) (car statements)))))))))
2129
2130 (define (ast-list->info info)
2131   (lambda (elements)
2132     (let loop ((elements elements) (info info))
2133       (if (null? elements) info
2134           (loop (cdr elements) ((ast->info info) (car elements)))))))
2135
2136 (define current-eval
2137   (let ((module (current-module)))
2138     (lambda (e) (eval e module))))
2139
2140 (define (object->list object)
2141   (text->list (map current-eval object)))
2142
2143 (define (dec->xhex o)
2144   (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
2145
2146 (define (write-lambda o)
2147   (newline)
2148   (display "    ")
2149   (if (or (not (pair? o))
2150           (not (eq? (caaddr o) 'list))) (write o)
2151           (list (car o) (cadr o)
2152                 (display (string-append "(lambda (f g ta t d) (list "
2153                                         (string-join (map dec->xhex (cdaddr o)) " ")
2154                                         "))")))))
2155
2156 (define (write-function o)
2157   (stderr "function: ~s\n" (car o))
2158   (newline)
2159   (display "  (")
2160   (write (car o)) (display " ")
2161   (if (not (cdr o)) (display ". #f")
2162       (for-each write-lambda (cdr o)))
2163   (display ")"))
2164
2165 (define (write-info o)
2166   (stderr "object:\n")
2167   (display "(make <info>\n")
2168   (display "  #:types\n  '") (pretty-print (.types o) #:width 80)
2169   (display "  #:constants\n  '") (pretty-print (.constants o) #:width 80)
2170   (display "  #:functions '(") (for-each write-function (.functions o)) (display ")") (newline)
2171   (stderr "globals:\n")
2172   (display "  #:globals\n  '") (pretty-print (.globals o) #:width 80)
2173   (stderr "init:\n")
2174   (display "  #:init\n  '") (pretty-print (.init o) #:width 80)
2175   (display ")\n"))
2176
2177 (define* (c99-input->info #:key (defines '()) (includes '()))
2178   (lambda ()
2179     (let* ((info (make <info> #:types i386:type-alist))
2180            (foo (stderr "parsing: input\n"))
2181            (ast (c99-input->ast #:defines defines #:includes includes))
2182            (foo (stderr "compiling: input\n"))
2183            (info ((ast->info info) ast))
2184            (info (clone info #:text '() #:locals '())))
2185       info)))
2186
2187 (define (write-any x)
2188   (write-char (cond ((char? x) x)
2189                     ((and (number? x) (< (+ x 256) 0))
2190                      (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
2191                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
2192                     ((procedure? x)
2193                      (stderr "write-any: proc: ~a\n" x)
2194                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
2195                      (error "procedure: write-any:" x))
2196                     (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
2197
2198 (define (info->elf info)
2199   (display "dumping elf\n" (current-error-port))
2200   (for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info))))
2201
2202 (define (function:object->text o)
2203   (cons (car o) (and (cdr o) (map current-eval (cdr o)))))
2204
2205 (define (init:object->text o)
2206   (current-eval o))
2207
2208 (define (info:object->text o)
2209   (clone o
2210          #:functions (map function:object->text (.functions o))
2211          #:init (map init:object->text (.init o))))
2212
2213 (define* (c99-ast->info ast)
2214   ((ast->info (make <info> #:types i386:type-alist)) ast))
2215
2216 (define* (c99-input->elf #:key (defines '()) (includes '()))
2217   ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
2218
2219 (define* (c99-input->object #:key (defines '()) (includes '()))
2220   ((compose write-info (c99-input->info #:defines defines #:includes includes))))
2221
2222 (define (object->elf info)
2223   ((compose info->elf info:object->text) info))
2224
2225 (define (infos->object infos)
2226   ((compose write-info merge-infos) infos))
2227
2228 (define (infos->elf infos)
2229   ((compose object->elf merge-infos) infos))
2230
2231 (define (merge-infos infos)
2232   (let loop ((infos infos) (info (make <info>)))
2233     (if (null? infos) info
2234         (loop (cdr infos)
2235               (clone info
2236                      #:types (alist-add (.types info) (.types (car infos)))
2237                      #:constants (alist-add (.constants info) (.constants (car infos)))
2238                      #:functions (alist-add (.functions info) (.functions (car infos)))
2239                      #:globals (alist-add (.globals info) (.globals (car infos)))
2240                      #:init (append (.init info) (.init (car infos))))))))
2241
2242 (define (alist-add a b)
2243   (let* ((b-keys (map car b))
2244          (a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a))
2245          (a-keys (map car a)))
2246     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))