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