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