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