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