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