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