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