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