a16f782461dbf9e1e14cdb452c61c141e3abc000
[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 `(#:string ,(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 (append globals (list (string->global 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 o)
977   (pmatch o
978     ((p-expr (string ,string)) (string->global string))
979     ((p-expr (fixed ,value)) (int->global (cstring->number value)))
980     (_ #f)))
981
982 (define (initzer->global o)
983   (pmatch o
984     ((initzer ,initzer) (expr->global initzer))
985     (_ #f)))
986
987 (define (byte->hex o)
988   (string->number (string-drop o 2) 16))
989
990 (define (asm->hex o)
991   (let ((prefix ".byte "))
992     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
993         (let ((s (string-drop o (string-length prefix))))
994           (map byte->hex (string-split s #\space))))))
995
996 (define (clause->jump-info info)
997   (define (jump n)
998     (wrap-as (i386:Xjump n)))
999   (define (jump-nz n)
1000     (wrap-as (i386:Xjump-nz n)))
1001   (define (jump-z n)
1002     (wrap-as (i386:Xjump-z n)))
1003   (define (statement->info info body-length)
1004     (lambda (o)
1005       (pmatch o
1006         ((break) (append-text info (jump body-length)))
1007         (_ ((ast->info info) o)))))
1008   (define (test->text test)
1009     (let ((value (pmatch test
1010                    (0 0)
1011                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
1012                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1013                    ((p-expr (fixed ,value)) (cstring->number value))
1014                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1015                    (_ (error "case test: unsupported: " test)))))
1016       (lambda (n)
1017         (append (wrap-as (i386:accu-cmp-value value))
1018                 (jump-z (+ (length (object->list (jump 0)))
1019                            (if (= n 0) 0
1020                                (* n (length (object->list ((test->text 0) 0)))))))))))
1021   (define (cases+jump cases clause-length)
1022     (append-text info
1023                  (append
1024                   (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
1025                   (if (null? cases) '()
1026                       (jump clause-length)))))
1027   (lambda (o)
1028     (lambda (body-length)
1029       (let loop ((o o) (cases '()) (clause #f))
1030         (pmatch o
1031           ((case ,test ,statement)
1032            (loop statement (append cases (list (test->text test))) clause))
1033           ((default ,statement)
1034            (loop statement cases clause))
1035           ((compd-stmt (block-item-list))
1036            (loop '() cases clause))
1037           ((compd-stmt (block-item-list . ,elements))
1038            (let ((clause (or clause (cases+jump cases 0))))
1039              (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1040                    ((statement->info clause body-length) (car elements)))))
1041           (()
1042            (let* ((cases-length (length (.text (cases+jump cases 0))))
1043                   (clause-text (list-tail (.text clause) cases-length))
1044                   (clause-length (length (object->list clause-text))))
1045              (clone clause #:text
1046                     (append (.text (cases+jump cases clause-length))
1047                             clause-text))))
1048           (_
1049            (let ((clause (or clause (cases+jump cases 0))))
1050              (loop '() cases
1051                    ((statement->info clause body-length) o)))))))))
1052
1053 (define (test->jump->info info)
1054   (define (jump type . test)
1055     (lambda (o)
1056       (let* ((text (.text info))
1057              (info (clone info #:text '()))
1058              (info ((ast->info info) o))
1059              (jump-text (lambda (body-length)
1060                           (wrap-as (type body-length)))))
1061         (lambda (body-length)
1062           (clone info #:text
1063                  (append text
1064                          (.text info)
1065                          (if (null? test) '() (car test))
1066                          (jump-text body-length)))))))
1067   (lambda (o)
1068     (pmatch o
1069       ;; unsigned
1070       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1071       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
1072       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1073       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1074
1075       ((le ,a ,b) ((jump i386:Xjump-g) o))
1076       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1077       ((ge ,a ,b) ((jump i386:Xjump-g) o))
1078       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1079
1080       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1081       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1082       ((not _) ((jump i386:Xjump-z) o))
1083       ((and ,a ,b)
1084        (let* ((globals (.globals info))
1085               (text (.text info))
1086               (info (clone info #:text '()))
1087
1088               (a-jump ((test->jump->info info) a))
1089               (a-text (.text (a-jump 0)))
1090               (a-length (length (object->list a-text)))
1091
1092               (b-jump ((test->jump->info info) b))
1093               (b-text (.text (b-jump 0)))
1094               (b-length (length (object->list b-text))))
1095
1096          (lambda (body-length)
1097            (let* ((info (append-text info text))
1098                   (a-info (a-jump (+ b-length body-length)))
1099                   (info (append-text info (.text a-info)))
1100                   (b-info (b-jump body-length))
1101                   (info (append-text info (.text b-info))))
1102             (clone info
1103                    #:globals (append globals
1104                                      (list-tail (.globals a-info) (length globals))
1105                                      (list-tail (.globals b-info) (length globals))))))))
1106
1107       ((or ,a ,b)
1108        (let* ((globals (.globals info))
1109               (text (.text info))
1110               (info (clone info #:text '()))
1111
1112               (a-jump ((test->jump->info info) a))
1113               (a-text (.text (a-jump 0)))
1114               (a-length (length (object->list a-text)))
1115
1116               (jump-text (wrap-as (i386:Xjump 0)))
1117               (jump-length (length (object->list jump-text)))
1118
1119               (b-jump ((test->jump->info info) b))
1120               (b-text (.text (b-jump 0)))
1121               (b-length (length (object->list b-text)))
1122
1123               (jump-text (wrap-as (i386:Xjump b-length))))
1124
1125          (lambda (body-length)
1126            (let* ((info (append-text info text))
1127                   (a-info (a-jump jump-length))
1128                   (info (append-text info (.text a-info)))
1129                   (info (append-text info jump-text))
1130                   (b-info (b-jump body-length))
1131                   (info (append-text info (.text b-info))))
1132             (clone info
1133                    #:globals (append globals
1134                                      (list-tail (.globals a-info) (length globals))
1135                                      (list-tail (.globals b-info) (length globals))))))))
1136
1137       ((array-ref . _) ((jump i386:jump-byte-z
1138                               (wrap-as (i386:accu-zero?))) o))
1139
1140       ((de-ref _) ((jump i386:jump-byte-z
1141                          (wrap-as (i386:accu-zero?))) o))
1142
1143       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1144        ((jump i386:Xjump-z
1145               (append
1146                ((ident->accu info) name)
1147                (wrap-as (i386:accu-zero?)))) o))
1148
1149       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1150
1151 (define (cstring->number s)
1152   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1153         ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1154         ((string-prefix? "0" s) (string->number s 8))
1155         (else (string->number s))))
1156
1157 (define (struct-field o)
1158   (pmatch o
1159     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1160                 (comp-declr-list (comp-declr (ident ,name))))
1161      (list name type 4))
1162     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1163      (list name type 4))
1164     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1165      (list name type 4))
1166     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1167      (list name type 4)) ;; FIXME: **
1168     ((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)))))
1169      (list name type 4)) ;; FIXME function / int
1170     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1171      (list name type 4)) ;; FIXME: ptr/char
1172     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1173      (list name type 4)) ;; FIXME: **
1174     ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1175      (list name '(void) 4)) ;; FIXME: *
1176     ((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)))))
1177      (list name '(void) 4))
1178     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1179      (list name '(void) 4))
1180     ((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)))))))
1181      (let ((size 4)
1182            (count (cstring->number count)))
1183        (list name type (* count size) 0)))
1184     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1185      (let ((size 4)
1186            (count (cstring->number count)))
1187        (list name type (* count size) 0)))
1188     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1189      (let ((size 4)
1190            (count (cstring->number count)))
1191        (list name type (* count size) 0)))
1192     ;; struct InlineFunc **inline_fns;
1193     ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1194      (list name type 4))
1195     ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1196      (list name type 4))
1197     (_ (error "struct-field: unsupported: " o))))
1198
1199 (define (ident->decl info o)
1200   (or (assoc-ref (.locals info) o)
1201       (assoc-ref (.globals info) o)
1202       (begin
1203         (stderr "NO IDENT: ~a\n" o)
1204         (assoc-ref (.functions info) o))))
1205
1206 (define (ident->type info o)
1207   (and=> (ident->decl info o) car))
1208
1209 (define (ident->pointer info o)
1210   (let ((local (assoc-ref (.locals info) o)))
1211     (if local (local:pointer local)
1212         (or (and=> (ident->decl info o) global:pointer) 0))))
1213
1214 (define (p-expr->type info o)
1215   (pmatch o
1216     ((p-expr (ident ,name)) (ident->type info name))
1217     ((array-ref ,index (p-expr (ident ,array)))
1218      (ident->type info array))
1219     (_ (error "p-expr->type: unsupported: " o))))
1220
1221 (define (get-type types o)
1222   (let ((t (assoc-ref types o)))
1223     (pmatch t
1224       ((typedef ,next) (get-type types next))
1225       (_ t))))
1226
1227 (define (type->description info o)
1228   (pmatch o
1229     ((decl-spec-list (type-spec (fixed-type ,type)))
1230      (type->description info type))
1231     ((struct-ref (ident ,type))
1232      (type->description info `("struct" ,type)))
1233     (_ (let ((type (get-type (.types info) o)))
1234          (if (not type) (stderr "TYPES=~s\n" (.types info)))
1235          (if type (caddr type)
1236              (error "type->description: unsupported:" o))))))
1237
1238 (define (local? o) ;; formals < 0, locals > 0
1239   (positive? (local:id o)))
1240
1241 (define (statements->clauses statements)
1242   (let loop ((statements statements) (clauses '()))
1243     (if (null? statements) clauses
1244         (let ((s (car statements)))
1245           (pmatch s
1246             ((case ,test (compd-stmt (block-item-list . _)))
1247              (loop (cdr statements) (append clauses (list s))))
1248             ((case ,test (break))
1249              (loop (cdr statements) (append clauses (list s))))
1250             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1251
1252             ((case ,test ,statement)
1253              (let loop2 ((statement statement) (heads `((case ,test))))
1254                (define (heads->case heads statement)
1255                  (if (null? heads) statement
1256                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1257                (pmatch statement
1258                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1259                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1260                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1261                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1262                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1263                           (let ((s (car statements)))
1264                             (pmatch s
1265                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1266                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1267                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1268                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1269             ((default (compd-stmt (block-item-list _)))
1270              (loop (cdr statements) (append clauses (list s))))
1271             ((default . ,statement)
1272              (let loop2 ((statements (cdr statements)) (c statement))
1273                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1274                    (let ((s (car statements)))
1275                      (pmatch s
1276                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1277                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1278                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1279                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1280
1281                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1282             (_ (error "statements->clauses: unsupported:" s)))))))
1283
1284 (define (ast->info info)
1285   (lambda (o)
1286     (let ((functions (.functions info))
1287           (globals (.globals info))
1288           (locals (.locals info))
1289           (constants (.constants info))
1290           (types (.types info))
1291           (text (.text info)))
1292       (define (add-local locals name type pointer)
1293         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1294                        (1+ (local:id (cdar locals)))))
1295                (locals (cons (make-local name type pointer id) locals)))
1296           locals))
1297       (define (declare name)
1298         (if (member name functions) info
1299             (clone info #:functions (cons (cons name #f) functions))))
1300       (pmatch o
1301         (((trans-unit . _) . _)
1302          ((ast-list->info info)  o))
1303         ((trans-unit . ,elements)
1304          ((ast-list->info info) elements))
1305         ((fctn-defn . _) ((function->info info) o))
1306         ((cpp-stmt (define (name ,name) (repl ,value)))
1307          info)
1308
1309         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1310          info)
1311
1312         ((break)
1313          (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text)))))))
1314
1315         ;; FIXME: expr-stmt wrapper?
1316         (trans-unit info)
1317         ((expr-stmt) info)
1318
1319         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1320         
1321         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1322          (let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
1323                 (info (append-text info (wrap-as `(#:comment ,source)))))
1324            (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1325                                      (append-text info (wrap-as (asm->hex arg0))))
1326               (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1327                 (append-text info (wrap-as (i386:accu-zero?)))))))
1328
1329         ((if ,test ,body)
1330          (let* ((text-length (length text))
1331
1332                 (test-jump->info ((test->jump->info info) test))
1333                 (test+jump-info (test-jump->info 0))
1334                 (test-length (length (.text test+jump-info)))
1335
1336                 (body-info ((ast->info test+jump-info) body))
1337                 (text-body-info (.text body-info))
1338                 (body-text (list-tail text-body-info test-length))
1339                 (body-length (length (object->list body-text)))
1340
1341                 (text+test-text (.text (test-jump->info body-length)))
1342                 (test-text (list-tail text+test-text text-length)))
1343
1344            (clone info #:text
1345                   (append text
1346                           test-text
1347                           body-text)
1348                   #:globals (.globals body-info))))
1349
1350         ((if ,test ,then ,else)
1351          (let* ((text-length (length text))
1352
1353                 (test-jump->info ((test->jump->info info) test))
1354                 (test+jump-info (test-jump->info 0))
1355                 (test-length (length (.text test+jump-info)))
1356
1357                 (then-info ((ast->info test+jump-info) then))
1358                 (text-then-info (.text then-info))
1359                 (then-text (list-tail text-then-info test-length))
1360                 (then-jump-text (wrap-as (i386:Xjump 0)))
1361                 (then-jump-length (length (object->list then-jump-text)))
1362                 (then-length (+ (length (object->list then-text)) then-jump-length))
1363
1364                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1365                 (else-info ((ast->info then+jump-info) else))
1366                 (text-else-info (.text else-info))
1367                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1368                 (else-length (length (object->list else-text)))
1369
1370                 (text+test-text (.text (test-jump->info then-length)))
1371                 (test-text (list-tail text+test-text text-length))
1372                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1373
1374            (clone info #:text
1375                   (append text
1376                           test-text
1377                           then-text
1378                           then-jump-text
1379                           else-text)
1380                   #:globals (append (.globals then-info)
1381                                     (list-tail (.globals else-info) (length globals))))))
1382
1383         ;; Hmm?
1384         ((expr-stmt (cond-expr ,test ,then ,else))
1385          (let* ((text-length (length text))
1386
1387                 (test-jump->info ((test->jump->info info) test))
1388                 (test+jump-info (test-jump->info 0))
1389                 (test-length (length (.text test+jump-info)))
1390
1391                 (then-info ((ast->info test+jump-info) then))
1392                 (text-then-info (.text then-info))
1393                 (then-text (list-tail text-then-info test-length))
1394                 (then-length (length (object->list then-text)))
1395
1396                 (jump-text (wrap-as (i386:Xjump 0)))
1397                 (jump-length (length (object->list jump-text)))
1398
1399                 (test+then+jump-info
1400                  (clone then-info
1401                         #:text (append (.text then-info) jump-text)))
1402
1403                 (else-info ((ast->info test+then+jump-info) else))
1404                 (text-else-info (.text else-info))
1405                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1406                 (else-length (length (object->list else-text)))
1407
1408                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1409                 (test-text (list-tail text+test-text text-length))
1410                 (jump-text (wrap-as (i386:Xjump else-length))))
1411
1412            (clone info #:text
1413                   (append text
1414                           test-text
1415                           then-text
1416                           jump-text
1417                           else-text)
1418                   #:globals (.globals else-info))))
1419
1420         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1421          (let* ((clauses (statements->clauses statements))
1422                 (expr ((expr->accu info) expr))
1423                 (empty (clone info #:text '()))
1424                 (clause-infos (map (clause->jump-info empty) clauses))
1425                 (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
1426                 (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
1427                               (if (null? clauses) info
1428                                   (let ((c-j ((clause->jump-info info) (car clauses))))
1429                                     (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1430            clauses-info))
1431
1432         ((for ,init ,test ,step ,body)
1433          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1434
1435                 (info ((ast->info info) init))
1436
1437                 (init-text (.text info))
1438                 (init-locals (.locals info))
1439                 (info (clone info #:text '()))
1440
1441                 (body-info ((ast->info info) body))
1442                 (body-text (.text body-info))
1443                 (body-length (length (object->list body-text)))
1444
1445                 (step-info ((expr->accu info) step))
1446                 (step-text (.text step-info))
1447                 (step-length (length (object->list step-text)))
1448
1449                 (test-jump->info ((test->jump->info info) test))
1450                 (test+jump-info (test-jump->info 0))
1451                 (test-length (length (object->list (.text test+jump-info))))
1452
1453                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1454
1455                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1456                 (jump-length (length (object->list jump-text)))
1457
1458                 (test-text (.text (test-jump->info jump-length))))
1459
1460            (clone info #:text
1461                   (append text
1462                           init-text
1463                           skip-body-text
1464                           body-text
1465                           step-text
1466                           test-text
1467                           jump-text)
1468                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1469                   #:locals locals)))
1470
1471         ((while ,test ,body)
1472          (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (ellipsis))))))
1473                 ;;(source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (compd-stmt (block-item-list)))))))
1474                 (skip-info (lambda (body-length test-length)
1475                              (clone info
1476                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1477                                     #:break (cons (+ (length (object->list text)) body-length test-length
1478                                                      (length (i386:Xjump 0)))
1479                                                   (.break info)))))
1480                 (text (.text (skip-info 0 0)))
1481                 (text-length (length text))
1482                 (body-info (lambda (body-length test-length)
1483                              ((ast->info (skip-info body-length test-length)) body)))
1484
1485                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1486                 (body-length (length (object->list body-text)))
1487
1488                 (empty (clone info #:text '()))
1489                 (test-jump->info ((test->jump->info empty) test))
1490                 (test+jump-info (test-jump->info 0))
1491                 (test-length (length (object->list (.text test+jump-info))))
1492
1493                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1494                 (jump-length (length (object->list jump-text)))
1495
1496                 (test-text (.text (test-jump->info jump-length)))
1497
1498                 (body-info (body-info body-length (length (object->list test-text)))))
1499
1500            (clone info #:text
1501                   (append
1502                    (wrap-as `(#:comment ,source))
1503                    (.text body-info)
1504                    test-text
1505                    jump-text)
1506                   #:globals (.globals body-info))))
1507
1508         ((do-while ,body ,test)
1509          (let* ((text-length (length text))
1510
1511                 (body-info ((ast->info info) body))
1512                 (body-text (list-tail (.text body-info) text-length))
1513                 (body-length (length (object->list body-text)))
1514
1515                 (empty (clone info #:text '()))
1516                 (test-jump->info ((test->jump->info empty) test))
1517                 (test+jump-info (test-jump->info 0))
1518                 (test-length (length (object->list (.text test+jump-info))))
1519
1520                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1521                 (jump-length (length (object->list jump-text)))
1522
1523                 (test-text (.text (test-jump->info jump-length))))
1524            (clone info #:text
1525                   (append
1526                    (.text body-info)
1527                    test-text
1528                    jump-text)
1529                   #:globals (.globals body-info))))
1530
1531         ((labeled-stmt (ident ,label) ,statement)
1532          (let ((info (append-text info `((#:label ,label)))))
1533            ((ast->info info) statement)))
1534
1535         ((goto (ident ,label))
1536          (let* ((jump (lambda (n) (i386:XXjump n)))
1537                 (offset (+ (length (jump 0)) (length (object->list text)))))
1538            (append-text info (list (i386:jump-label `(#:local ,label))))))
1539
1540         ((return ,expr)
1541          (let ((info ((expr->accu info) expr)))
1542            (append-text info (append (wrap-as (i386:ret))))))
1543
1544         ;; DECL
1545
1546         ;; int i;
1547         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1548          (if (.function info)
1549              (clone info #:locals (add-local locals name type 0))
1550              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1551
1552         ;; enum e i;
1553         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1554          (let ((type "int")) ;; FIXME
1555            (if (.function info)
1556                (clone info #:locals (add-local locals name type 0))
1557                (clone info #:globals (append globals (list (ident->global name type 0 0)))))))
1558
1559         ;; int i = 0;
1560         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1561          (let ((value (cstring->number value)))
1562            (if (.function info)
1563                (let* ((locals (add-local locals name type 0))
1564                       (info (clone info #:locals locals)))
1565                  (append-text info ((value->ident info) name value)))
1566                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1567
1568         ;; char c = 'A';
1569         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1570          (if (not (.function info)) (error "ast->info: unsupported: " o))
1571          (let* ((locals (add-local locals name type 0))
1572                 (info (clone info #:locals locals))
1573                 (value (char->integer (car (string->list value)))))
1574            (append-text info ((value->ident info) name value))))
1575
1576         ;; int i = -1;
1577         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1578          (let ((value (- (cstring->number value))))
1579            (if (.function info)
1580                (let* ((locals (add-local locals name type 0))
1581                       (info (clone info #:locals locals)))
1582                  (append-text info ((value->ident info) name value)))
1583                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1584
1585         ;; int i = argc;
1586         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1587          (if (not (.function info)) (error "ast->info: unsupported: " o))
1588          (let* ((locals (add-local locals name type 0))
1589                 (info (clone info #:locals locals)))
1590            (append-text info (append ((ident->accu info) local)
1591                                      ((accu->ident info) name)))))
1592
1593         ;; char *p = "foo";
1594         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1595          (if (.function info)
1596              (let* ((locals (add-local locals name type 1))
1597                     (globals (append globals (list (string->global string))))
1598                     (info (clone info #:locals locals #:globals globals)))
1599                (append-text info (append
1600                                   (list (i386:label->accu `(#:string ,string)))
1601                                   ((accu->ident info) name))))
1602              (let* ((global (string->global string))
1603                     (globals (append globals (list global)))
1604                     (size 4)
1605                     (global (make-global name type 1 (initzer->data `(initzer (p-expr (string ,string))))))
1606                     (globals (append globals (list global))))
1607                (clone info #:globals globals))))
1608         
1609         ;; char *p;
1610         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1611          (if (.function info)
1612              (let* ((locals (add-local locals name type 1))
1613                     (info (clone info #:locals locals)))
1614                (append-text info (append (wrap-as (i386:value->accu 0))
1615                                          ((accu->ident info) name))))
1616              (let ((globals (append globals (list (ident->global name type 1 0)))))
1617                (clone info #:globals globals))))
1618
1619         ;; char *p = 0;
1620         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1621          (let ((value (cstring->number value)))
1622            (if (.function info)
1623                (let* ((locals (add-local locals name type 1))
1624                       (info (clone info #:locals locals)))
1625                  (append-text info (append (wrap-as (i386:value->accu value))
1626                                            ((accu->ident info) name))))
1627                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1628
1629         ;; FILE *p;
1630         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1631          (if (.function info)
1632              (let* ((locals (add-local locals name type 1))
1633                     (info (clone info #:locals locals)))
1634                (append-text info (append (wrap-as (i386:value->accu 0))
1635                                          ((accu->ident info) name))))
1636              (let ((globals (append globals (list (ident->global name type 1 0)))))
1637                (clone info #:globals globals))))
1638
1639         ;; FILE *p = 0;
1640         ((decl (decl-spec-list (type-spec (typename ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1641          (let ((value (cstring->number value)))
1642            (if (.function info)
1643                (let* ((locals (add-local locals name type 1))
1644                       (info (clone info #:locals locals)))
1645                  (append-text info (append (wrap-as (i386:value->accu value))
1646                                            ((accu->ident info) name))))
1647                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1648
1649         ;; char **p;
1650         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1651          (if (.function info)
1652              (let* ((locals (add-local locals name type 2))
1653                     (info (clone info #:locals locals)))
1654                (append-text info (append (wrap-as (i386:value->accu 0))
1655                                          ((accu->ident info) name))))
1656              (let ((globals (append globals (list (ident->global name type 2 0)))))
1657                (clone info #:globals globals))))
1658
1659         ;; char **p = g_environment;
1660         ((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
1661          (if (.function info)
1662              (let* ((locals (add-local locals name type 2))
1663                     (info (clone info #:locals locals)))
1664                (append-text info (append
1665                                   ((ident->accu info) b)
1666                                   ((accu->ident info) name))))
1667              (let* ((value (assoc-ref constants b))
1668                     (global (ident->global name type 2 (initzer->data `(p-expr (fixed ,value)))))
1669                     (globals (append globals (list global))))
1670                (clone info #:globals globals))))
1671
1672         ;; struct foo bar[2];
1673         ;; char arena[20000];
1674         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1675          (let ((type (ast->type type)))
1676            (if (.function info)
1677                (let* ((local (car (add-local locals name type -1)))
1678                       (count (string->number count))
1679                       (size (type->size info type))
1680                       (local (make-local name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))                      
1681                       (locals (cons local locals))
1682                       (info (clone info #:locals locals)))
1683                  info)
1684                (let* ((globals (.globals info))
1685                       (count (cstring->number count))
1686                       (size (type->size info type))
1687                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1688                       (globals (append globals (list array))))
1689                  (clone info #:globals globals)))))
1690
1691         ;; char* a[10];
1692         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1693          (let ((type (ast->type type)))
1694            (if (.function info)
1695                (let* ((local (car (add-local locals name type -1)))
1696                       (count (string->number count))
1697                       (size (type->size info type))
1698                       (local (make-local name type 1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))
1699                       (locals (cons local locals))
1700                       (info (clone info #:locals locals)))
1701                  info)
1702                (let* ((globals (.globals info))
1703                       (count (cstring->number count))
1704                       (size (type->size info type))
1705                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1706                       (globals (append globals (list array))))
1707                  (clone info #:globals globals)))))
1708
1709         ;; struct foo bar;
1710         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1711          (if (.function info)
1712              (let* ((size (type->size info (list "struct" type)))
1713                     (local (car (add-local locals name type 1)))
1714                     (local (make-local name `("struct" ,type) -1 (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
1715                     (locals (cons local locals)))
1716                (clone info #:locals locals))
1717              (let* ((size (type->size info (list "struct" type)))
1718                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1719                     (globals (append globals (list global)))
1720                     (info (clone info #:globals globals)))
1721                info)))
1722
1723         ;;struct scm *g_cells = (struct scm*)arena;
1724         ((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)))))))
1725          (if (.function info)
1726              (let* ((locals (add-local locals name `("struct" ,type) 1))
1727                     (info (clone info #:locals locals)))
1728                (append-text info (append ((ident->accu info) name)
1729                                          ((accu->ident info) value)))) ;; FIXME: deref?
1730              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1731                     (info (clone info #:globals globals)))
1732                (append-text info (append ((ident->accu info) name)
1733                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1734
1735         ;; SCM tmp;
1736         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1737          (if (.function info)
1738              (let ((size (type->size info type)))
1739                (if (<= size 4) (clone info #:locals (add-local locals name type 0))
1740                    (let* ((local (car (add-local locals name type 1)))
1741                           (local (make-local name type -1 (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
1742                           (locals (cons local locals)))
1743                      (clone info #:locals locals))))
1744              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1745
1746         ;; SCM g_stack = 0;
1747         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1748          (let ((value (cstring->number value)))
1749            (if (.function info)
1750                (let* ((locals (add-local locals name type 0))
1751                       (info (clone info #:locals locals)))
1752                  (append-text info ((value->ident info) name value)))
1753                (let ((globals (append globals (list (ident->global name type 0 value)))))
1754                  (clone info #:globals globals)))))
1755
1756         ;; SCM i = argc;
1757         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1758          (if (.function info)
1759              (let* ((locals (add-local locals name type 0))
1760                     (info (clone info #:locals locals)))
1761                (append-text info (append ((ident->accu info) local)
1762                                          ((accu->ident info) name))))
1763              (let* ((globals (append globals (list (ident->global name type 0 0))))
1764                     (info (clone info #:globals globals)))
1765                (append-text info (append ((ident->accu info) local)
1766                                          ((accu->ident info) name))))))
1767
1768         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1769         ((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))))
1770          (let* ((locals (add-local locals name type 1))
1771                 (info (clone info #:locals locals))
1772                 (empty (clone info #:text '()))
1773                 (accu ((expr->accu empty) initzer)))
1774            (clone info
1775                   #:text
1776                   (append text
1777                           (.text accu)
1778                           ((accu->ident info) name)
1779                           (wrap-as (append (i386:label->base `(#:address "_start"))
1780                                            (i386:accu+base))))
1781                   #:locals locals)))
1782
1783         ;; char *p = (char*)g_cells;
1784         ((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)))))))
1785          (if (.function info)
1786              (let* ((locals (add-local locals name type 1))
1787                     (info (clone info #:locals locals)))
1788                (append-text info (append ((ident->accu info) value)
1789                                          ((accu->ident info) name))))
1790              (let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
1791                (clone info #:globals globals))))
1792
1793         ;; char *p = g_cells;
1794         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1795          (let ((type (decl->type type)))
1796            (if (.function info)
1797                (let* ((locals (add-local locals name type  1))
1798                       (info (clone info #:locals locals)))
1799                  (append-text info (append ((ident->accu info) value)
1800                                            ((accu->ident info) name))))
1801                (let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
1802                  (clone info #:globals globals)))))
1803
1804         ;; enum foo { };
1805         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1806          (let ((type (enum->type name fields))
1807                (constants (enum-def-list->constants constants fields)))
1808            (clone info
1809                   #:types (append types (list type))
1810                   #:constants (append constants (.constants info)))))
1811
1812         ;; enum {};
1813         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1814          (let ((constants (enum-def-list->constants constants fields)))
1815            (clone info
1816                   #:constants (append constants (.constants info)))))
1817
1818         ;; FIXME TCC/Nyacc madness here: extra parentheses around struct name?!?
1819         ;; struct (FOO) WTF?
1820         ((decl (decl-spec-list (type-spec (struct-def (ident (,name)) (field-list . ,fields)))))
1821          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1822            (clone info #:types (append types (list type)))))
1823
1824         ((decl (decl-spec-list (type-spec (struct-def (ident (,type)) (field-list . ,fields))))
1825                (init-declr-list (init-declr (ident ,name))))
1826          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1827            ((ast->info info)
1828             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1829
1830         ;; struct foo* bar = expr;
1831          ((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)))))))
1832          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1833                                      (info (clone info #:locals locals)))
1834                  (append-text info (append ((ident-address->accu info) value)
1835                                            ((accu->ident info) name))))
1836              (error "ast->info: unsupported global:" o)))
1837          ;; END FIXME -- dupe of the below
1838
1839
1840         ;; struct
1841         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1842          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1843            (clone info #:types (cons type types))))
1844
1845         ;; struct foo {} bar;
1846         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1847                (init-declr-list (init-declr (ident ,name))))
1848          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1849            ((ast->info info)
1850             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1851
1852         ;; struct foo* bar = expr;
1853          ((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)))))))
1854          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1855                                      (info (clone info #:locals locals)))
1856                  (append-text info (append ((ident-address->accu info) value)
1857                                            ((accu->ident info) name))))
1858              (error "ast->info: unsupported global:" o)))
1859
1860         ;; char *p = &bla;
1861         ((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)))))))
1862          (let ((type (decl->type type)))
1863            (if (.function info)
1864                (let* ((locals (add-local locals name type 1))
1865                       (info (clone info #:locals locals)))
1866                  (append-text info (append ((ident-address->accu info) value)
1867                                            ((accu->ident info) name))))
1868                (error "TODO" o))))
1869
1870         ;; char **p = &bla;
1871         ((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)))))))
1872          (let ((type (decl->type type)))
1873            (if (.function info)
1874                (let* ((locals (add-local locals name type 2))
1875                       (info (clone info #:locals locals)))
1876                  (append-text info (append ((ident-address->accu info) value)
1877                                            ((accu->ident info) name))))
1878                (error "TODO" o))))
1879
1880         ;; char *p = bla[0];
1881         ((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)))))))
1882          (if (.function info)
1883              (let* ((locals (add-local locals name type 1))
1884                     (info (clone info #:locals locals))
1885                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1886                (append-text info ((accu->ident info) name)))
1887              (error "TODO" o)))
1888
1889         ;; char *foo = &bar[0];
1890         ((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))))))))
1891          (if (.function info)
1892              (let* ((locals (add-local locals name type 1))
1893                     (info (clone info #:locals locals))
1894                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1895                (append-text info ((accu->ident info) name)))
1896              (error "TODO" o)))
1897
1898         ;; char *p = *bla;
1899         ((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)))))))
1900          (if (.function info)
1901              (let* ((locals (add-local locals name type 1))
1902                     (info (clone info #:locals locals))
1903                     (local (assoc-ref (.locals info) name)))
1904                (append-text info (append ((ident->accu info) value)
1905                                          (wrap-as (i386:mem->accu))
1906                                          ((accu->ident info) name))))
1907              (error "TODO" o)))
1908
1909         ;; DECL
1910         ;; char *bla[] = {"a", "b"};
1911         ((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)))))
1912          (let* ((type (decl->type type))
1913                 (entries (map initzer->global initzers))
1914                 (entry-size 4)
1915                 (size (* (length entries) entry-size))
1916                 (initzers (map (initzer->non-const info) initzers)))
1917            (if (.function info)
1918                (error "TODO: <type> x[] = {};" o)
1919                (let* (;;(global (make-global name type 2 (string->list (make-string size #\nul))))
1920                       (global (make-global name type 2 (append-map initzer->data initzers)))
1921                       (globals (append globals entries (list global))))
1922                  (clone info #:globals globals)))))
1923
1924         ;;
1925         ;; struct f = {...};
1926         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1927          (let* ((type (decl->type type))
1928                 (fields (type->description info type))
1929                 (size (type->size info type))
1930                 (initzers (map (initzer->non-const info) initzers)))
1931            (if (.function info)
1932                (let* ((globals (append globals (filter-map initzer->global initzers)))
1933                       (locals (let loop ((fields (cdr fields)) (locals locals))
1934                                 (if (null? fields) locals
1935                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1936                       (locals (add-local locals name type -1))
1937                       (info (clone info #:locals locals #:globals globals))
1938                       (empty (clone info #:text '())))
1939                  (let loop ((fields fields) (initzers initzers) (info info))
1940                    (if (null? fields) info
1941                        (let ((offset (field-offset info type (caar fields)))
1942                              (initzer (car initzers)))
1943                          (loop (cdr fields) (cdr initzers)
1944                                (clone info #:text
1945                                       (append
1946                                        (.text info)
1947                                        ((ident->accu info) name)
1948                                        (wrap-as (append (i386:accu->base)))
1949                                        (.text ((expr->accu empty) initzer))
1950                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1951                (let* ((globals (append globals (filter-map initzer->global initzers)))
1952                       (global (make-global name type 2 (append-map initzer->data initzers)))
1953                       (globals (append globals (list global))))
1954                  (clone info #:globals globals)))))
1955
1956
1957         ;;char cc = g_cells[c].cdr;  ==> generic?
1958         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1959          (let ((type (decl->type type))
1960                (initzer ((initzer->non-const info) initzer)))
1961            (if (.function info)
1962                (let* ((locals (add-local locals name type 0))
1963                       (info (clone info #:locals locals)))
1964                  (clone info #:text
1965                         (append (.text ((expr->accu info) initzer))
1966                                 ((accu->ident info) name))))
1967                (let* ((global (make-global name type 2 (initzer->data initzer)))
1968                       (globals (append globals (list global))))
1969                  (clone info #:globals globals)))))
1970
1971         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1972          (declare name))
1973
1974         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1975          (clone info #:types (cons (cons name (get-type types type)) types)))
1976
1977         ;; int foo ();
1978         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1979          (declare name))
1980
1981         ;; void foo ();
1982         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1983          (declare name))
1984
1985         ;; void foo (*);
1986         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1987          (declare name))
1988
1989         ;; char *strcpy ();
1990         ((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))))))
1991          (declare name))
1992
1993         ;; printf (char const* format, ...)
1994         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1995          (declare name))
1996
1997         ;; <name> tcc_new
1998         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1999          (declare name))
2000
2001         ;; extern type foo ()
2002         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2003          (declare name))
2004
2005         ;; struct TCCState;
2006         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
2007          info)
2008
2009         ;; extern type global;
2010         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
2011          info)
2012
2013         ;; ST_DATA struct TCCState *tcc_state;
2014         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2015          info)
2016
2017         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
2018         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
2019          info)
2020
2021         ;; ST_DATA const int *macro_ptr;
2022         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2023          info)
2024
2025         ;; ST_DATA TokenSym **table_ident;
2026         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
2027          info)
2028
2029         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
2030         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
2031          info)
2032
2033         ;; ST_DATA void **sym_pools;
2034         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
2035          info)
2036
2037         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
2038         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
2039          info)
2040
2041         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
2042         ;; Yay, let's hear it for the T-for Tiny in TCC!?
2043         ((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)))))
2044          info)
2045
2046         ;; ST_DATA char *funcname;
2047         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2048          info)
2049
2050         ;; int i = 0, j = 0;
2051         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2052          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2053            (if (null? inits) info
2054                (loop (cdr inits)
2055                      ((ast->info info)
2056                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2057
2058         ;; char *foo[0], *bar;
2059         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,index)) . ,rest))
2060          (let loop ((inits `((init-declr (array-of (ident ,name) ,index)) ,@rest)) (info info))
2061            (if (null? inits) info
2062                (loop (cdr inits)
2063                      ((ast->info info)
2064                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2065
2066
2067         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name))))
2068          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2069
2070         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2071          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2072
2073         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2074          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2075
2076         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
2077          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
2078
2079         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
2080          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name)))))))
2081            (clone info #:types (cons (cons name (or (get-type types `("struct" ,name)) `(typedef ,name))) types))))
2082
2083         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2084          (format (current-error-port) "SKIP: typedef=~s\n" o)
2085          info)        
2086
2087         ((decl (@ ,at))
2088          (format (current-error-port) "SKIP: at=~s\n" o)
2089          info)
2090
2091         ((decl . _) (error "ast->info: unsupported: " o))
2092
2093         ;; ...
2094         ((gt . _) ((expr->accu info) o))
2095         ((ge . _) ((expr->accu info) o))
2096         ((ne . _) ((expr->accu info) o))
2097         ((eq . _) ((expr->accu info) o))
2098         ((le . _) ((expr->accu info) o))
2099         ((lt . _) ((expr->accu info) o))
2100         ((lshift . _) ((expr->accu info) o))
2101         ((rshift . _) ((expr->accu info) o))
2102
2103         ;; EXPR
2104         ((expr-stmt ,expression)
2105          (let ((info ((expr->accu info) expression)))
2106            (append-text info (wrap-as (i386:accu-zero?)))))
2107
2108         ;; FIXME: why do we get (post-inc ...) here
2109         ;; (array-ref
2110         (_ (let ((info ((expr->accu info) o)))
2111              (append-text info (wrap-as (i386:accu-zero?)))))))))
2112
2113 (define (enum-def-list->constants constants fields)
2114   (let loop ((fields fields) (i 0) (constants constants))
2115     (if (null? fields) constants
2116         (let* ((field (car fields))
2117                (name (pmatch field
2118                        ((enum-defn (ident ,name) . _) name)))
2119                (i (pmatch field
2120                     ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
2121                     ((enum-defn ,name) i)
2122                     ((enum-defn ,name (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2123                      (+ (cstring->number a) (cstring->number b)))
2124                     ((enum-defn ,name (sub (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2125                      (- (cstring->number a) (cstring->number b)))
2126                     (_ (error "not supported enum field=~s\n" field)))))
2127           (loop (cdr fields)
2128                 (1+ i)
2129                 (append constants (list (ident->constant name i))))))))
2130
2131 (define (initzer->non-const info)
2132   (lambda (o)
2133     (pmatch o
2134       ((initzer (p-expr (ident ,name)))
2135        (let ((value (assoc-ref (.constants info) name)))
2136          `(initzer (p-expr (fixed ,(number->string value))))))
2137       (_ o))))
2138
2139 (define (initzer->data o)
2140   (pmatch o
2141     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2142     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2143     ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
2144     ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
2145     (_ (error "initzer->data: unsupported: " o))))
2146
2147 (define (.formals o)
2148   (pmatch o
2149     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2150     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2151     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2152     (_ (error ".formals: " o))))
2153
2154 (define (formal->text n)
2155   (lambda (o i)
2156     ;;(i386:formal i n)
2157     '()
2158     ))
2159
2160 (define (formals->text o)
2161   (pmatch o
2162     ((param-list . ,formals)
2163      (let ((n (length formals)))
2164        (wrap-as (append (i386:function-preamble)
2165                         (append-map (formal->text n) formals (iota n))
2166                         (i386:function-locals)))))
2167     (_ (error "formals->text: unsupported: " o))))
2168
2169 (define (formal:ptr o)
2170   (pmatch o
2171     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2172      0)
2173     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2174      2)
2175     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2176      1)
2177     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2178      1)
2179     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2180      2)
2181     (_
2182      (stderr "formal:ptr[~a] => ~a\n" o 0)
2183      0)))
2184
2185 (define (formals->locals o)
2186   (pmatch o
2187     ((param-list . ,formals)
2188      (let ((n (length formals)))
2189        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2190     (_ (error "formals->locals: unsupported: " o))))
2191
2192 (define (function->info info)
2193   (lambda (o)
2194     (define (assert-return text)
2195       (let ((return (wrap-as (i386:ret))))
2196         (if (equal? (list-tail text (- (length text) (length return))) return) text
2197             (append text return))))
2198     (let* ((name (.name o))
2199            (formals (.formals o))
2200            (text (formals->text formals))
2201            (locals (formals->locals formals)))
2202       (format (current-error-port) "compiling: ~a\n" name)
2203       (let loop ((statements (.statements o))
2204                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2205         (if (null? statements) (clone info
2206                                       #:function #f
2207                                       #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2208             (let* ((statement (car statements)))
2209               (loop (cdr statements)
2210                     ((ast->info info) (car statements)))))))))
2211
2212 (define (ast-list->info info)
2213   (lambda (elements)
2214     (let loop ((elements elements) (info info))
2215       (if (null? elements) info
2216           (loop (cdr elements) ((ast->info info) (car elements)))))))
2217
2218 (define (object->list object)
2219   (apply append (filter (lambda (x) (and (pair? x) (not (member (car x) '(#:comment #:label))))) object)))
2220
2221 (define* (c99-input->info #:key (defines '()) (includes '()))
2222   (lambda ()
2223     (let* ((info (make <info> #:types i386:type-alist))
2224            (foo (stderr "parsing: input\n"))
2225            (ast (c99-input->ast #:defines defines #:includes includes))
2226            (foo (stderr "compiling: input\n"))
2227            (info ((ast->info info) ast))
2228            (info (clone info #:text '() #:locals '())))
2229       info)))
2230
2231 (define* (info->object o)
2232   `((functions . ,(.functions o))
2233     (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2234
2235 (define* (c99-ast->info ast)
2236   ((ast->info (make <info> #:types i386:type-alist)) ast))
2237
2238 (define* (c99-input->elf #:key (defines '()) (includes '()))
2239   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2240
2241 (define* (c99-input->object #:key (defines '()) (includes '()))
2242   ((compose write-hex3 info->object (c99-input->info #:defines defines #:includes includes))))