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