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