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