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