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