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