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