97f5fc85c1947976fac152820a8a2bfe5744c95d
[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 (struct-ref (ident ,name))))))
530          (let* ((type (list "struct" name))
531                 (size (ast-type->size info type)))
532            (append-text info (wrap-as (i386:value->accu size)))))
533
534         ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,type))) (abs-declr (pointer))))
535          (let ((size 4))
536            (append-text info (wrap-as (i386:value->accu size)))))
537
538         ;; c+p expr->arg
539         ;; g_cells[<expr>]
540         ((array-ref ,index (p-expr (ident ,array)))
541          (let* ((type (ident->type info array))
542                 (ptr (ident->pointer info array))
543                 (size (if (or (= ptr 1) (= ptr -1)) (ast-type->size info type)
544                           4))
545                 (info ((expr->accu* info) o)))
546            (append-text info (wrap-as (append (case size
547                                                 ((1) (i386:byte-mem->accu))
548                                                 ((4) (i386:mem->accu))
549                                                 (else '())))))))
550
551         ;; foo.bar[baz])
552         ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
553          (let ((info ((expr->accu* info) o)))
554            (append-text info (wrap-as (i386:mem->accu)))))
555
556         ;; foo->bar[baz])
557         ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
558          (let ((info ((expr->accu* info) o)))
559            (append-text info (wrap-as (i386:mem->accu)))))
560
561         ;; <expr>[baz]
562         ((array-ref ,index ,array)
563          (let ((info ((expr->accu* info) o)))
564            (append-text info (wrap-as (i386:mem->accu)))))
565
566         ;; f.field
567         ((d-sel (ident ,field) (p-expr (ident ,array)))
568          (let* ((type (ident->type info array))
569                 (offset (field-offset info type field))
570                 (text (.text info)))
571            (append-text info (append ((ident->accu info) array)
572                                      (wrap-as (i386:mem+n->accu offset))))))
573
574         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
575          (let* ((type (ident->type info array))
576                 (offset (field-offset info type field))
577                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
578            (append-text info (wrap-as (i386:mem+n->accu offset)))))
579
580         ((i-sel (ident ,field) (p-expr (ident ,array)))
581          (let* ((type (ident->type info array))
582                 (offset (field-offset info type field))
583                 (text (.text info)))
584            (append-text info (append ((ident-address->accu info) array)
585                                      (wrap-as (i386:mem->accu))
586                                      (wrap-as (i386:mem+n->accu offset))))))
587
588         ((i-sel (ident ,field) (de-ref (p-expr (ident ,array))))
589          (let* ((type (ident->type info array))
590                 (offset (field-offset info type field))
591                 (text (.text info)))
592            (append-text info (append ((ident-address->accu info) array)
593                                      (wrap-as (i386:mem->accu))
594                                      (wrap-as (i386:mem->accu))
595                                      (wrap-as (i386:mem+n->accu offset))))))
596
597         ((de-ref (p-expr (ident ,name)))
598          (let* ((type (ident->type info name))
599                 (ptr (ident->pointer info name))
600                 (size (if (= ptr 1) (ast-type->size info type)
601                           4)))
602            (append-text info (append (if (or #t (assoc-ref locals name)) ((ident->accu info) name)
603                                          ((ident-address->accu info) name))
604                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
605                                                   (i386:mem->accu)))))))
606
607         ((de-ref (post-inc (p-expr (ident ,name))))
608          (let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
609                 (type (ident->type info name))
610                 (ptr (ident->pointer info name))
611                 (size (if (= ptr 1) (ast-type->size info type)
612                           4)))
613            (append-text info ((ident-add info) name size))))
614
615         ((de-ref ,expr)
616          (let ((info ((expr->accu info) expr)))
617            (append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
618
619         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
620          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
621                                    (append-text info (wrap-as (asm->m1 arg0))))
622              (let* ((text-length (length text))
623                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
624                                  (if (null? expressions) info
625                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
626                     (n (length expr-list)))
627                (if (not (assoc-ref locals name))
628                    (begin
629                      (if (and (not (assoc name (.functions info)))
630                               (not (assoc name globals))
631                               (not (equal? name (.function info))))
632                          (stderr "warning: undeclared function: ~a\n" name))
633                      (append-text args-info (list (i386:call-label name n))))
634                    (let* ((empty (clone info #:text '()))
635                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
636                      (append-text args-info (append (.text accu)
637                                                     (list (i386:call-accu n)))))))))
638
639         ((fctn-call ,function (expr-list . ,expr-list))
640          (let* ((text-length (length text))
641                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
642                              (if (null? expressions) info
643                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
644                 (n (length expr-list))
645                 (empty (clone info #:text '()))
646                 (accu ((expr->accu empty) function)))
647            (append-text args-info (append (.text accu)
648                                           (list (i386:call-accu n))))))
649
650         ((cond-expr . ,cond-expr)
651          ((ast->info info) `(expr-stmt ,o)))
652
653         ((post-inc (p-expr (ident ,name)))
654          (let* ((type (ident->type info name))
655                 (ptr (ident->pointer info name))
656                 (size (if (> ptr 1) 4 1)))
657            (append-text info (append ((ident->accu info) name)
658                                      ((ident-add info) name size)))))
659
660         ((post-dec (p-expr (ident ,name)))
661          (append-text info (append ((ident->accu info) name)
662                                    ((ident-add info) name -1))))
663
664         ((pre-inc (p-expr (ident ,name)))
665          (append-text info (append ((ident-add info) name 1)
666                                    ((ident->accu info) name))))
667
668         ((pre-dec (p-expr (ident ,name)))
669          (append-text info (append ((ident-add info) name -1)
670                                    ((ident->accu info) name))))
671
672         ((post-inc ,expr)
673          (let* ((info (append ((expr->accu info) expr)))
674                 (info (append-text info (wrap-as (i386:push-accu))))
675                 (ptr (expr->pointer info expr))
676                 (size (if (> ptr 0) 4 1))
677                 (info ((expr-add info) expr size))
678                 (info (append-text info (wrap-as (i386:pop-accu)))))
679            info))
680
681         ((post-dec ,expr)
682          (let* ((info (append ((expr->accu info) expr)))
683                 (info (append-text info (wrap-as (i386:push-accu))))
684                 (ptr (expr->pointer info expr))
685                 (size (if (> ptr 0) 4 1))
686                 (info ((expr-add info) expr (- size)))
687                 (info (append-text info (wrap-as (i386:pop-accu)))))
688            info))
689
690         ((pre-inc ,expr)
691          (let* ((ptr (expr->pointer info expr))
692                 (size (if (> ptr 0) 4 1))
693                 (info ((expr-add info) expr size))
694                 (info (append ((expr->accu info) expr))))
695            info))
696
697         ((pre-dec ,expr)
698          (let* ((ptr (expr->pointer info expr))
699                 (size (if (> ptr 0) 4 1))
700                 (info ((expr-add info) expr (- size)))
701                 (info (append ((expr->accu info) expr))))
702            info))
703
704         ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
705         ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
706         ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
707         ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
708         ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
709         ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
710         ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
711         ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
712         ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
713         ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
714
715         ((not ,expr)
716          (let* ((test-info ((ast->info info) expr)))
717            (clone info #:text
718                   (append (.text test-info)
719                           (wrap-as (i386:accu-not)))
720                   #:globals (.globals test-info))))
721
722         ((neg (p-expr (fixed ,value)))
723          (append-text info (value->accu (- (cstring->number value)))))
724
725         ((neg (p-expr (ident ,name)))
726          (append-text info (append ((ident->base info) name)
727                                    (wrap-as (i386:value->accu 0))
728                                    (wrap-as (i386:sub-base)))))
729
730         ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
731         ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
732         ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
733
734         ;; FIXME: set accu *and* flags
735         ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
736                                                     (i386:sub-base)
737                                                     (i386:nz->accu)
738                                                     (i386:accu<->stack)
739                                                     (i386:sub-base)
740                                                     (i386:xor-zf)
741                                                     (i386:pop-accu))))
742
743         ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
744         ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
745         ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
746
747         ((or ,a ,b)
748          (let* ((info ((expr->accu info) a))
749                 (here (number->string (length (.text info))))
750                 (skip-b-label (string-append (.function info) "_" here "_or_skip_b"))
751                 (info (append-text info (wrap-as (i386:accu-test))))
752                 (info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
753                 (info (append-text info (wrap-as (i386:accu-test))))
754                 (info ((expr->accu info) b))
755                 (info (append-text info (wrap-as (i386:accu-test))))
756                 (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
757            info))
758
759         ((and ,a ,b)
760          (let* ((info ((expr->accu info) a))
761                 (here (number->string (length (.text info))))
762                 (skip-b-label (string-append (.function info) "_" here "_and_skip_b"))
763                 (info (append-text info (wrap-as (i386:accu-test))))
764                 (info (append-text info (wrap-as (i386:jump-z skip-b-label))))
765                 (info (append-text info (wrap-as (i386:accu-test))))
766                 (info ((expr->accu info) b))
767                 (info (append-text info (wrap-as (i386:accu-test))))
768                 (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
769            info))
770
771         ((cast ,cast ,o)
772          ((expr->accu info) o))
773
774         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
775          (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))
776                 (type (ident->type info name))
777                 (ptr (ident->pointer info name))
778                 (size (if (> ptr 1) 4 1)))
779            (append-text info ((ident-add info) name size)))) ;; FIXME: size
780
781         ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
782          (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))
783                 (type (ident->type info name))
784                 (ptr (ident->pointer info name))
785                 (size (if (> ptr 1) 4 1)))
786            (append-text info ((ident-add info) name (- size))))) ;; FIXME: size
787
788         ((assn-expr ,a (op ,op) ,b)
789          (let* ((info (append-text info (ast->comment o)))
790                 (info ((expr->accu info) b))
791                 (info (if (equal? op "=") info
792                           (let* ((info (append-text info (wrap-as (i386:push-accu))))
793                                  (info ((expr->accu info) a))
794                                  (info (append-text info (wrap-as (i386:pop-base)))))
795                             (append-text info (cond ((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%base)))
800                                                     ((equal? op "|=") (wrap-as (i386:accu-or-base)))
801                                                     (else (error "mescc: op ~a not supported: ~a\n" op o))))))))
802            (pmatch a
803              ((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
804              ((d-sel (ident ,field) ,p-expr)
805               (let* ((type (p-expr->type info p-expr))
806                      (offset (field-offset info type field))
807                      (info (append-text info (wrap-as (i386:push-accu))))
808                      (info ((expr->accu* info) a))
809                      (info (append-text info (wrap-as (i386:pop-base)))))
810                 (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
811              ((de-ref (p-expr (ident ,name)))
812               (let* ((type (ident->type info name))
813                      (ptr (ident->pointer info name))
814                      (size (if (= ptr 1) (ast-type->size info type)
815                           4)))
816                 (append-text info (append (wrap-as (i386:accu->base))
817                                           ((base->ident-address info) name)))))
818              ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
819               (let* ((info (append-text info (wrap-as (i386:push-accu))))
820                      (info ((expr->accu* info) a))
821                      (info (append-text info (wrap-as (i386:pop-base)))))
822                 (append-text info (wrap-as (i386:base->accu-address)))))
823              ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
824               (let* ((info (append-text info (wrap-as (i386:push-accu))))
825                      (info ((expr->accu* info) a))
826                      (info (append-text info (wrap-as (i386:pop-base)))))
827                 (append-text info (wrap-as (i386:base->accu-address)))))
828              ((array-ref ,index (p-expr (ident ,array)))
829               (let* ((type (ident->type info array))
830                      (size (ast-type->size info type))
831                      (info (append-text info (wrap-as (i386:push-accu))))
832                      (info ((expr->accu* info) a))
833                      (info (append-text info (wrap-as (i386:pop-base)))))
834                 (append-text info
835                              (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
836                                          (if (<= size 4) (wrap-as (i386:base->accu-address))
837                                           (append
838                                            (wrap-as (i386:base-address->accu-address))
839                                            (wrap-as (append (i386:accu+n 4)
840                                                             (i386:base+n 4)
841                                                             (i386:base-address->accu-address)))
842                                            (if (<= size 8) '()
843                                                (wrap-as (append (i386:accu+n 4)
844                                                                 (i386:base+n 4)
845                                                                 (i386:base-address->accu-address)))))))))))
846
847              ((i-sel (ident ,field) ,array)
848               (let* ((info (append-text info (wrap-as (i386:push-accu))))
849                      (info ((expr->accu* info) a))
850                      (info (append-text info (wrap-as (i386:pop-base)))))
851                 (append-text info (wrap-as (i386:base->accu-address)))))
852
853              (_ (error "expr->accu: unsupported assign: " a)))))
854
855         (_ (error "expr->accu: unsupported: " o))))))
856
857 (define (expr->base info)
858   (lambda (o)
859     (let* ((info (append-text info (wrap-as (i386:push-accu))))
860            (info ((expr->accu info) o))
861            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
862       info)))
863
864 (define (binop->accu info)
865   (lambda (a b c)
866     (let* ((info ((expr->accu info) a))
867            (info ((expr->base info) b)))
868       (append-text info (wrap-as c)))))
869
870 (define (wrap-as o . annotation)
871   `(,@annotation ,o))
872
873 (define (make-comment o)
874   (wrap-as `((#:comment ,o))))
875
876 (define (ast->comment o)
877   (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
878     (make-comment (string-join (string-split source #\newline) " "))))
879
880 (define (expr->accu* info)
881   (lambda (o)
882     (pmatch o
883       ;; g_cells[<expr>]
884       ((array-ref ,index (p-expr (ident ,array)))
885        (let* ((info ((expr->accu info) index))
886               (type (ident->type info array))
887               (ptr (ident->pointer info array))
888               (size (if (or (= ptr 1) (= ptr -1)) (ast-type->size info type)
889                         4)))
890          (append-text info (append (wrap-as (append (i386:accu->base)
891                                                     (if (eq? size 1) '()
892                                                         (append
893                                                          (if (<= size 4) '()
894                                                              (i386:accu+accu))
895                                                          (if (<= size 8) '()
896                                                              (i386:accu+base))
897                                                          (i386:accu-shl 2)))))
898                                    ((ident->base info) array)
899                                    (wrap-as (i386:accu+base))))))
900
901       ;; g_cells[<expr>].type
902       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
903        (let* ((type (ident->type info array))
904               (offset (field-offset info type field))
905               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
906          (append-text info (wrap-as (i386:accu+value offset)))))
907
908       ((d-sel (ident ,field) (p-expr (ident ,name)))
909        (let* ((type (ident->type info name))
910               (offset (field-offset info type field))
911               (text (.text info)))
912          (append-text info (append ((ident->accu info) name)
913                                    (wrap-as (i386:accu+value offset))))))
914
915       ;; foo.bar[baz]
916       ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,name))))
917        (let* ((type (ident->type info name))
918               (offset (field-offset info type field))
919               (info ((expr->accu info) index)))
920          (append-text info (append (wrap-as (append (i386:accu-shl 2) ;; FIXME: assume size=4
921                                                     (i386:push-accu)))
922                                    ((ident-address->accu info) name)
923                                    (wrap-as (append (i386:accu+value offset)
924                                                     (i386:pop-base)
925                                                     (i386:accu+base)))))))
926
927       ;; foo->bar[baz]
928       ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,name))))
929        (let* ((type (ident->type info name))
930               (offset (field-offset info type field))
931               (info ((expr->accu info) index)))
932          (append-text info (append (wrap-as (append (i386:accu-shl 2) ;; FIXME: assume size=4
933                                                     (i386:push-accu)))
934                                    ((ident->accu info) name)
935                                    (wrap-as (append (i386:accu+value offset)
936                                                     (i386:pop-base)
937                                                     (i386:accu+base)))))))
938       
939       ((array-ref ,index ,array)
940        (let* ((info ((expr->accu info) index))
941               (size 4) ;; FIXME
942               (info (append-text info (wrap-as (append (i386:accu->base)
943                                                        (if (eq? size 1) '()
944                                                            (append
945                                                             (if (<= size 4) '()
946                                                                 (i386:accu+accu))
947                                                             (if (<= size 8) '()
948                                                                 (i386:accu+base))
949                                                             (i386:accu-shl 2)))))))
950               (info ((expr->base info) array)))
951           (append-text info (wrap-as (i386:accu+base)))))
952
953       ((i-sel (ident ,field) (p-expr (ident ,array)))
954        (let* ((type (ident->type info array))
955               (offset (field-offset info type field))
956               (text (.text info)))
957          (append-text info (append ((ident-address->accu info) array)
958                                    (wrap-as (i386:mem->accu))
959                                    (wrap-as (i386:accu+value offset))))))
960
961       ((i-sel (ident ,field) (de-ref (p-expr (ident ,array))))
962        (let* ((type (ident->type info array))
963               (offset (field-offset info type field))
964               (text (.text info)))
965          (append-text info (append ((ident-address->accu info) array)
966                                    (wrap-as (i386:mem->accu))
967                                    (wrap-as (i386:mem->accu))
968                                    (wrap-as (i386:accu+value offset))))))
969
970       (_ (error "expr->accu*: unsupported: " o)))))
971
972 (define (ident->constant name value)
973   (cons name value))
974
975 (define (enum->type-entry name fields)
976   (cons name (make-type 'enum 4 0 fields)))
977
978 (define (struct->type-entry name fields)
979   (cons (list "struct" name) (make-type 'struct (apply + (map field:size fields)) 0 fields)))
980
981 (define (union->type-entry name fields)
982   (cons (list "struct" name) (make-type 'union (apply + (map field:size fields)) 0 fields)))
983
984 (define i386:type-alist
985   `(("char" . ,(make-type 'builtin 1 0 #f))
986     ("short" . ,(make-type 'builtin 2 0 #f))
987     ("int" . ,(make-type 'builtin 4 0 #f))
988     ("long" . ,(make-type 'builtin 4 0 #f))
989     ("long long" . ,(make-type 'builtin 8 0 #f))
990     ("void" . ,(make-type 'builtin 4 0 #f))
991     ;; FIXME sign
992     ("unsigned char" . ,(make-type 'builtin 1 0 #f))
993     ("unsigned short" . ,(make-type 'builtin 2 0 #f))
994     ("unsigned" . ,(make-type 'builtin 4 0 #f))
995     ("unsigned int" . ,(make-type 'builtin 4 0 #f))
996     ("unsigned long" . ,(make-type 'builtin 4 0 #f))
997     ("unsigned long long" . ,(make-type 'builtin 8 0 #f))))
998
999 (define (field:size o)
1000   (pmatch o
1001     ((,name ,type ,size ,pointer) size)
1002     (_ 4)))
1003
1004 (define (get-type types o)
1005   (let ((t (assoc-ref types o)))
1006     (pmatch t
1007       ((typedef ,next) (get-type types next))
1008       (_ t))))
1009
1010 (define (ast-type->type info o)
1011   (pmatch o
1012     ((decl-spec-list (type-spec (fixed-type ,type)))
1013      (ast-type->type info type))
1014     ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
1015      (ast-type->type info type))
1016     ((struct-ref (ident (,type)))
1017      (ast-type->type info `("struct" ,type)))
1018     ((struct-ref (ident ,type))
1019      (ast-type->type info `("struct" ,type)))
1020     ((union-ref (ident ,type))
1021      (ast-type->type info `("struct" ,type)))
1022     ((void) (ast-type->type info "void"))
1023     (_ (let ((type (get-type (.types info) o)))
1024          (if type type
1025              (begin
1026                (stderr "types: ~s\n" (.types info))
1027                (error "ast-type->type: unsupported: " o)))))))
1028
1029 (define (ast-type->description info o)
1030   (let ((type (ast-type->type info o)))
1031     (type:description type)))
1032
1033 (define (ast-type->size info o)
1034   (let ((type (ast-type->type info o)))
1035     (type:size type)))
1036
1037 (define (field-offset info struct field)
1038   (let ((xtype (ast-type->type info struct)))
1039     (if (eq? (type:type xtype) 'union) 0
1040         (let* ((fields (type:description xtype))
1041                (prefix (and=> (member field (reverse fields) (lambda (a b) (equal? a (car b)))) cdr)))
1042           (apply + (map field:size prefix))))))
1043
1044 (define (ast->type o)
1045   (pmatch o
1046     ((fixed-type ,type)
1047      type)
1048     ((typename ,type)
1049      type)
1050     ((struct-ref (ident (,type)))
1051      (list "struct" type))
1052     ((struct-ref (ident ,type))
1053      (list "struct" type))
1054     (_ (stderr "SKIP: type=~s\n" o)
1055        "int")))
1056
1057 (define (decl->ast-type o)
1058   (pmatch o
1059     ((fixed-type ,type) type)
1060     ((struct-ref (ident (,name))) (list "struct" name))
1061     ((struct-ref (ident ,name)) (list "struct" name))
1062     ((struct-def (ident ,name) . ,fields) (list "struct" name))
1063     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm"
1064      (list "struct" name)) ;; FIXME
1065     ((typename ,name) name)
1066     (,name name)
1067     (_ (error "decl->ast-type: unsupported: " o))))
1068
1069 (define (byte->hex.m1 o)
1070   (string-drop o 2))
1071
1072 (define (asm->m1 o)
1073   (let ((prefix ".byte "))
1074     (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
1075         (let ((s (string-drop o (string-length prefix))))
1076           (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
1077
1078 (define (clause->info info i label last?)
1079   (define clause-label
1080     (string-append label "clause" (number->string i)))
1081   (define body-label
1082     (string-append label "body" (number->string i)))
1083   (define (jump label)
1084     (wrap-as (i386:jump label)))
1085   (define (jump-nz label)
1086     (wrap-as (i386:jump-nz label)))
1087   (define (jump-z label)
1088     (wrap-as (i386:jump-z label)))
1089   (define (test->text test)
1090     (let ((value (pmatch test
1091                    (0 0)
1092                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
1093                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1094                    ((p-expr (fixed ,value)) (cstring->number value))
1095                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1096                    (_ (error "case test: unsupported: " test)))))
1097       (append (wrap-as (i386:accu-cmp-value value))
1098               (jump-z body-label))))
1099   (define (cases+jump info cases)
1100     (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
1101            (next-clause-label (if last? (string-append label "break")
1102                                   (string-append label "clause" (number->string (1+ i)))))
1103            (info (append-text info (apply append cases)))
1104            (info (if (null? cases) info
1105                      (append-text info (jump next-clause-label))))
1106            (info (append-text info (wrap-as `((#:label ,body-label))))))
1107       info))
1108
1109   (lambda (o)
1110     (let loop ((o o) (cases '()) (clause #f))
1111       (pmatch o
1112         ((case ,test ,statement)
1113          (loop statement (append cases (list (test->text test))) clause))
1114         ((default ,statement)
1115          (loop statement cases clause))
1116         ((compd-stmt (block-item-list))
1117          (loop '() cases clause))
1118         ((compd-stmt (block-item-list . ,elements))
1119          (let ((clause (or clause (cases+jump info cases))))
1120            (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1121                  ((ast->info clause) (car elements)))))
1122         (()
1123          (let ((clause (or clause (cases+jump info cases))))
1124            (if last? clause
1125                (let ((next-body-label (string-append label "body"
1126                                                      (number->string (1+ i)))))
1127                  (append-text clause (wrap-as (i386:jump next-body-label)))))))
1128         (_
1129          (let ((clause (or clause (cases+jump info cases))))
1130            (loop '() cases
1131                  ((ast->info clause) o))))))))
1132
1133 (define (test-jump-label->info info label)
1134   (define (jump type . test)
1135     (lambda (o)
1136       (let* ((info ((ast->info info) o))
1137              (info (append-text info (make-comment "jmp test LABEL")))
1138              (jump-text (wrap-as (type label))))
1139         (append-text info (append (if (null? test) '() (car test))
1140                                   jump-text)))))
1141   (lambda (o)
1142     (pmatch o
1143       ;; unsigned
1144       ;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
1145       ;; ((lt ,a ,b) ((jump i386:jump-nc) o))  ; jae
1146       ;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
1147       ;; ((gt ,a ,b) ((jump i386:jump-nc) o))
1148
1149       ((le ,a ,b) ((jump i386:jump-g) o))
1150       ((lt ,a ,b) ((jump i386:jump-ge) o))
1151       ((ge ,a ,b) ((jump i386:jump-g) o))
1152       ((gt ,a ,b) ((jump i386:jump-ge) o))
1153
1154       ((ne ,a ,b) ((jump i386:jump-nz) o))
1155       ((eq ,a ,b) ((jump i386:jump-nz) o))
1156       ((not _) ((jump i386:jump-z) o))
1157
1158       ((and ,a ,b)
1159        (let* ((info ((test-jump-label->info info label) a))
1160               (info ((test-jump-label->info info label) b)))
1161          info))
1162
1163       ((or ,a ,b)
1164        (let* ((here (number->string (length (.text info))))
1165               (skip-b-label (string-append label "_skip_b_" here))
1166               (b-label (string-append label "_b_" here))
1167               (info ((test-jump-label->info info b-label) a))
1168               (info (append-text info (wrap-as (i386:jump skip-b-label))))
1169               (info (append-text info (wrap-as `((#:label ,b-label)))))
1170               (info ((test-jump-label->info info label) b))
1171               (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1172          info))
1173
1174       ((array-ref . _) ((jump i386:jump-byte-z
1175                               (wrap-as (i386:accu-zero?))) o))
1176
1177       ((de-ref _) ((jump i386:jump-byte-z
1178                          (wrap-as (i386:accu-zero?))) o))
1179
1180       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1181        ((jump i386:jump-z
1182               (append ((ident->accu info) name)
1183                       (wrap-as (i386:accu-zero?)))) o))
1184
1185       (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
1186
1187 (define (cstring->number s)
1188   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1189         ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1190         ((string-prefix? "0" s) (string->number s 8))
1191         (else (string->number s))))
1192
1193 (define (struct-field info)
1194   (lambda (o)
1195     (pmatch o
1196       ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1197                   (comp-declr-list (comp-declr (ident ,name))))
1198        (list name type 4))
1199       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1200        (list name type 4))
1201       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1202        (list name type 4))
1203       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1204        (list name type 4)) ;; FIXME: **
1205       ((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)))))
1206        (list name type 4)) ;; FIXME function / int
1207       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1208        (list name type 4)) ;; FIXME: ptr/char
1209       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1210        (list name type 4)) ;; FIXME: **
1211       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1212        (list name '(void) 4)) ;; FIXME: *
1213       ((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)))))
1214        (list name '(void) 4))
1215       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1216        (list name type 4))
1217       ((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)))))))
1218        (let ((size 4)
1219              (count (cstring->number count)))
1220          (list name type (* count size) 0)))
1221       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1222        (let ((size 4)
1223              (count (cstring->number count)))
1224          (list name type (* count size) 0)))
1225       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1226        (let ((size 4)
1227              (count (cstring->number count)))
1228          (list name type (* count size) 0)))
1229       ;; struct InlineFunc **inline_fns;
1230       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1231        (list name type 4))
1232       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1233        (list name type 4))
1234
1235       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1236        (let ((size (ast-type->size info `("struct" ,type))))
1237          (list name type size 0)))
1238
1239       (_ (error "struct-field: unsupported: " o)))
1240     )
1241   )
1242
1243 (define (ident->decl info o)
1244   (or (assoc-ref (.locals info) o)
1245       (assoc-ref (.globals info) o)
1246       (begin
1247         (stderr "NO IDENT: ~a\n" o)
1248         (assoc-ref (.functions info) o))))
1249
1250 (define (ident->type info o)
1251   (let ((type (ident->decl info o)))
1252     (cond ((global? type) (global:type type))
1253           ((local? type) (local:type type))
1254           (else (stderr "ident->type ~s => ~s\n" o type)
1255                 (car type)))))
1256
1257 (define (ident->pointer info o)
1258   (let ((local (assoc-ref (.locals info) o)))
1259     (if local (local:pointer local)
1260         (or (and=> (ident->decl info o) global:pointer) 0))))
1261
1262 (define (p-expr->type info o)
1263   (pmatch o
1264     ((p-expr (ident ,name)) (ident->type info name))
1265     ((array-ref ,index (p-expr (ident ,array)))
1266      (ident->type info array))
1267     (_ (error "p-expr->type: unsupported: " o))))
1268
1269 (define (local-var? o) ;; formals < 0, locals > 0
1270   (positive? (local:id o)))
1271
1272 (define (ptr-declr->pointer o)
1273   (pmatch o
1274     ((pointer) 1)
1275     ((pointer (pointer)) 2)
1276     (_ (error "ptr-declr->pointer unsupported: " o))))
1277
1278 (define (init-declr->name o)
1279   (pmatch o
1280     ((ident ,name) name)
1281     ((ptr-declr ,pointer (ident ,name)) name)
1282     ((array-of (ident ,name) ,index) name)
1283     (_ (error "init-declr->name unsupported: " o))))
1284
1285 (define (init-declr->pointer o)
1286   (pmatch o
1287     ((ident ,name) 0)
1288     ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer))
1289     ((array-of (ident ,name) ,index) 1)
1290     (_ (error "init-declr->pointer unsupported: " o))))
1291
1292 (define (statements->clauses statements)
1293   (let loop ((statements statements) (clauses '()))
1294     (if (null? statements) clauses
1295         (let ((s (car statements)))
1296           (pmatch s
1297             ((case ,test (compd-stmt (block-item-list . _)))
1298              (loop (cdr statements) (append clauses (list s))))
1299             ((case ,test (break))
1300              (loop (cdr statements) (append clauses (list s))))
1301             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1302
1303             ((case ,test ,statement)
1304              (let loop2 ((statement statement) (heads `((case ,test))))
1305                (define (heads->case heads statement)
1306                  (if (null? heads) statement
1307                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1308                (pmatch statement
1309                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1310                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1311                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1312                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1313                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1314                           (let ((s (car statements)))
1315                             (pmatch s
1316                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1317                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1318                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1319                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1320             ((default (compd-stmt (block-item-list _)))
1321              (loop (cdr statements) (append clauses (list s))))
1322             ((default . ,statement)
1323              (let loop2 ((statements (cdr statements)) (c statement))
1324                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1325                    (let ((s (car statements)))
1326                      (pmatch s
1327                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1328                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1329                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1330                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1331
1332                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1333             (_ (error "statements->clauses: unsupported:" s)))))))
1334
1335 (define (decl->info info)
1336   (lambda (o)
1337     (let ((functions (.functions info))
1338           (globals (.globals info))
1339           (locals (.locals info))
1340           (constants (.constants info))
1341           (types (.types info))
1342           (text (.text info)))
1343       (define (add-local locals name type pointer)
1344         (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
1345                        (1+ (local:id (cdar locals)))))
1346                (locals (cons (make-local-entry name type pointer id) locals)))
1347           locals))
1348       (define (declare name)
1349         (if (member name functions) info
1350             (clone info #:functions (cons (cons name #f) functions))))
1351       (pmatch o
1352
1353         ;; FIXME: Nyacc sometimes produces extra parens: (ident (<struct-name>))
1354         ((decl (decl-spec-list (stor-spec ,spec) (type-spec (struct-ref (ident (,type))))) ,init)
1355          ((decl->info info) `(decl (decl-spec-list (stor-spec ,spec) (type-spec (struct-ref (ident ,type)))) ,init)))
1356         ((decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1357          ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))))
1358
1359         ((decl (decl-spec-list (type-spec (struct-def (ident (,type)) ,field-list))))
1360          ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
1361
1362         ((decl (decl-spec-list (stor-spec ,spec) (type-spec (union-ref (ident (,type))))) ,init)
1363          ((decl->info info) `(decl (decl-spec-list (stor-spec ,spec) (type-spec (union-ref (ident ,type)))) ,init)))
1364         ((decl (decl-spec-list (type-spec (union-def (ident (,type)) ,field-list))))
1365          ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
1366
1367         ((decl (decl-spec-list (type-spec (union-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name) ,initzer)))
1368          ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name) ,initzer)))))
1369
1370
1371         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1372          (declare name))
1373
1374         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1375          (clone info #:types (cons (cons name (get-type types type)) types)))
1376
1377         ;; int foo ();
1378         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1379          (declare name))
1380
1381         ;; void foo ();
1382         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1383          (declare name))
1384
1385         ;; void foo (*);
1386         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1387          (declare name))
1388
1389         ;; char *strcpy ();
1390         ((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))))))
1391          (declare name))
1392
1393         ;; printf (char const* format, ...)
1394         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1395          (declare name))
1396
1397         ;; <name> tcc_new
1398         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1399          (declare name))
1400
1401         ;; extern type foo ()
1402         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1403          (declare name))
1404
1405         ;; struct TCCState;
1406         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
1407          info)
1408
1409         ;; extern type global;
1410         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
1411          info)
1412
1413         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ident ,name))))
1414          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ident ,name)))))
1415          info)
1416
1417         ;; extern foo *bar;
1418         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1419          info)
1420
1421         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1422          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))))
1423
1424         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
1425         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1426          info)
1427
1428         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
1429         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
1430          info)
1431
1432         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
1433         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1434          info)
1435
1436         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
1437         ;; Yay, let's hear it for the T-for Tiny in TCC!?
1438         ((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)))))
1439          info)
1440
1441         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1442          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
1443
1444         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1445          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
1446
1447         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1448          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
1449
1450         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1451          ((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))))))
1452
1453         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1454          ((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))))))
1455
1456         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1457          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
1458                 (types (.types info)))
1459            (clone info #:types (cons (cons name (or (get-type types `("struct" ,type)) `(typedef ,type))) types))))
1460
1461         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1462          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
1463                 (types (.types info)))
1464            (clone info #:types (cons (cons name (or (get-type types `("struct" ,type)) `(typedef ,type))) types))))
1465
1466         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1467          (let* ((type (get-type types type))
1468                 (type (make-type (type:type type)
1469                                  (type:size type)
1470                                  (1+ (type:pointer type))
1471                                  (type:description type)))
1472                 (type-entry (cons name type)))
1473            (clone info #:types (cons type-entry types))))
1474
1475         ;; struct
1476         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1477          (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1478            (clone info #:types (cons type-entry types))))
1479
1480         ;; enum e i;
1481         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1482          (let ((type "int")) ;; FIXME
1483            (if (.function info)
1484                (clone info #:locals (add-local locals name type 0))
1485                (clone info #:globals (append globals (list (ident->global-entry name type 0 0)))))))
1486
1487          ;; char **p;
1488         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1489          (if (.function info)
1490              (let ((locals (add-local locals name type 2)))
1491                (clone info #:locals locals))
1492              (let ((globals (append globals (list (ident->global-entry name type 2 0)))))
1493                (clone info #:globals globals))))
1494
1495          ;; char **p = *x;
1496         ((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)))))))
1497          (let ((type (decl->ast-type type))
1498                (info (append-text info (ast->comment o))))
1499            (if (.function info)
1500                (let* ((locals (add-local locals name type 2))
1501                       (info (clone info #:locals locals)))
1502                  (append-text info (append ((ident-address->accu info) value)
1503                                            (wrap-as (i386:mem->accu))
1504                                            ((accu->ident info) name))))
1505                (error "TODO" o))))
1506
1507         ;; struct foo bar[2];
1508         ;; char arena[20000];
1509         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1510          (let ((type (ast->type type)))
1511            (if (.function info)
1512                (let* ((local (car (add-local locals name type -1)))
1513                       (count (string->number count))
1514                       (size (ast-type->size info type))
1515                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))                      
1516                       (locals (cons local locals))
1517                       (info (clone info #:locals locals)))
1518                  info)
1519                (let* ((globals (.globals info))
1520                       (count (cstring->number count))
1521                       (size (ast-type->size info type))
1522                       (array (make-global-entry name type -1 (string->list (make-string (* count size) #\nul))))
1523                       (globals (append globals (list array))))
1524                  (clone info #:globals globals)))))
1525
1526         ((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))))))
1527          (if (.function info)
1528              (error  "TODO: " o)
1529              (let* ((globals (.globals info))
1530                     ;; (count (cstring->number count))
1531                     ;; (size (ast-type->size info type))
1532                     (array (make-global-entry array type -1 (string->list string)))
1533                     (globals (append globals (list array))))
1534                (clone info #:globals globals))))
1535
1536         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1537         ((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))))
1538          (let* ((locals (add-local locals name type 1))
1539                 (info (clone info #:locals locals))
1540                 (empty (clone info #:text '()))
1541                 (accu ((expr->accu empty) initzer)))
1542            (clone info
1543                   #:text
1544                   (append text
1545                           (.text accu)
1546                           ((accu->ident info) name)
1547                           (wrap-as (append (i386:label->base `(#:address "_start"))
1548                                            (i386:accu+base))))
1549                   #:locals locals)))
1550
1551         ;; char *p = g_cells;
1552         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1553          (let ((info (append-text info (ast->comment o)))
1554                (type (decl->ast-type type)))
1555            (if (.function info)
1556                (let* ((locals (add-local locals name type  1))
1557                       (info (clone info #:locals locals)))
1558                  (append-text info (append ((ident->accu info) value)
1559                                            ((accu->ident info) name))))
1560                (let ((globals (append globals (list (ident->global-entry name type 1 `(,value #f #f #f))))))
1561                  (clone info #:globals globals)))))
1562
1563         ;; enum foo { };
1564         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1565          (let ((type-entry (enum->type-entry name fields))
1566                (constants (enum-def-list->constants constants fields)))
1567            (clone info
1568                   #:types (cons type-entry types)
1569                   #:constants (append constants (.constants info)))))
1570
1571         ;; enum {};
1572         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1573          (let ((constants (enum-def-list->constants constants fields)))
1574            (clone info
1575                   #:constants (append constants (.constants info)))))
1576
1577         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1578          (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1579            (clone info #:types (cons type-entry types))))
1580
1581         ((decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))))
1582          (let ((type-entry (union->type-entry name (map (struct-field info) fields))))
1583            (clone info #:types (cons type-entry types))))
1584
1585         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1586                (init-declr-list (init-declr (ident ,name))))
1587          (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1588            ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1589
1590         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,fields))) (init-declr-list (init-declr (ident ,name))))
1591          (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,fields)))))))
1592            ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1593
1594         ;; struct f = {...};
1595         ;; LOCALS!
1596         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1597          (let* ((info (append-text info (ast->comment o)))
1598                 (type (decl->ast-type type))
1599                 (fields (ast-type->description info type))
1600                 (xtype (ast-type->type info type))
1601                 (fields (if (not (eq? (type:type xtype) 'union)) fields
1602                             (list-head fields 1)))
1603                 (size (ast-type->size info type))
1604                 (initzers (map (initzer->non-const info) initzers)))
1605            (if (.function info)
1606                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1607                       (global-names (map car globals))
1608                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1609                       (globals (append globals initzer-globals))
1610                       (locals (let loop ((fields (cdr fields)) (locals locals))
1611                                 (if (null? fields) locals
1612                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1613                       (locals (add-local locals name type -1))
1614                       (info (clone info #:locals locals #:globals globals))
1615                       (empty (clone info #:text '())))
1616                  (let loop ((fields fields) (initzers initzers) (info info))
1617                    (if (null? fields) info
1618                        (let ((offset (field-offset info type (caar fields)))
1619                              (initzer (car initzers)))
1620                          (loop (cdr fields) (cdr initzers)
1621                                (clone info #:text
1622                                       (append
1623                                        (.text info)
1624                                        ((ident->accu info) name)
1625                                        (wrap-as (append (i386:accu->base)))
1626                                        (.text ((expr->accu empty) initzer))
1627                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1628                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1629                       (global-names (map car globals))
1630                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1631                       (globals (append globals initzer-globals))
1632                       (global (make-global-entry name type -1 (append-map (initzer->data info) initzers)))
1633                       (globals (append globals (list global))))
1634                  (clone info #:globals globals)))))
1635
1636         ;; DECL
1637         ;; char *bla[] = {"a", "b"};
1638         ((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)))))
1639          (let* ((type (decl->ast-type type))
1640                 (entries (filter identity (append-map (initzer->globals globals) initzers)))
1641                 (entry-size 4)
1642                 (size (* (length entries) entry-size))
1643                 (initzers (map (initzer->non-const info) initzers)))
1644            (if (.function info)
1645                (error "TODO: <type> x[] = {};" o)
1646                (let* ((global (make-global-entry name type -2 (append-map (initzer->data info) initzers)))
1647                       (global-names (map car globals))
1648                       (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
1649                       (globals (append globals entries (list global))))
1650                  (clone info #:globals globals)))))
1651
1652         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
1653          (let* ((info (type->info info type))
1654                 (type (decl->ast-type type))
1655                 (name (init-declr->name init))
1656                 (pointer (init-declr->pointer init))
1657                 (initzer-globals (if (null? initzer) '()
1658                                      (filter identity (append-map (initzer->globals globals) initzer))))
1659                 (global-names (map car globals))
1660                 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1661                 (initzer (if (null? initzer) '() ((initzer->non-const info) initzer)))
1662                 (info (append-text info (ast->comment o)))
1663                 (globals (append globals initzer-globals))
1664                 (info (clone info #:globals globals))
1665                 (pointer (if (and (pair? type) (equal? (car type) "struct")) -1 pointer))
1666                 (size (if (zero? pointer) (ast-type->size info type)
1667                           4)))
1668            (if (.function info)
1669                (let* ((locals (if (or (not (= pointer 0)) (<= size 4)) (add-local locals name type pointer)
1670                                   (let* ((local (car (add-local locals name type 1)))
1671                                          (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))))
1672                                     (cons local locals))))
1673                       (info (clone info #:locals locals))
1674                       (info (if (null? initzer) info ((initzer->accu info) (car initzer))))
1675                       (info (if (null? initzer) info (append-text info ((accu->ident info) name)))))
1676                  info)
1677                (let* ((global (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul))
1678                                                                        (append-map (initzer->data info) initzer))))
1679                       (globals (append globals (list global))))
1680                  (clone info #:globals globals)))))
1681
1682         ;; int i = 0, j = 0;
1683         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
1684          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
1685            (if (null? inits) info
1686                (loop (cdr inits)
1687                      ((decl->info info)
1688                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
1689
1690         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1691          (format (current-error-port) "SKIP: typedef=~s\n" o)
1692          info)        
1693
1694         ((decl (@ ,at))
1695          (format (current-error-port) "SKIP: at=~s\n" o)
1696          info)
1697
1698         ((decl . _) (error "decl->info: unsupported: " o))))))
1699
1700 (define (ast->info info)
1701   (lambda (o)
1702     (let ((functions (.functions info))
1703           (globals (.globals info))
1704           (locals (.locals info))
1705           (constants (.constants info))
1706           (types (.types info))
1707           (text (.text info)))
1708       (pmatch o
1709         (((trans-unit . _) . _)
1710          ((ast-list->info info)  o))
1711         ((trans-unit . ,elements)
1712          ((ast-list->info info) elements))
1713         ((fctn-defn . _) ((function->info info) o))
1714         ((cpp-stmt (define (name ,name) (repl ,value)))
1715          info)
1716
1717         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1718          info)
1719
1720         ((break)
1721          (let ((label (car (.break info))))
1722            (append-text info (wrap-as (i386:jump label)))))
1723
1724         ((continue)
1725          (let ((label (car (.continue info))))
1726            (append-text info (wrap-as (i386:jump label)))))
1727
1728         ;; FIXME: expr-stmt wrapper?
1729         (trans-unit info)
1730         ((expr-stmt) info)
1731
1732         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1733         
1734         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1735          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1736                                    (append-text info (wrap-as (asm->m1 arg0))))
1737              (let* ((info (append-text info (ast->comment o)))
1738                     (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1739                (append-text info (wrap-as (i386:accu-zero?))))))
1740
1741         ((if ,test ,then)
1742          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
1743                 (here (number->string (length text)))
1744                 (label (string-append (.function info) "_" here "_"))
1745                 (break-label (string-append label "break"))
1746                 (else-label (string-append label "else"))
1747                 (info ((test-jump-label->info info break-label) test))
1748                 (info ((ast->info info) then))
1749                 (info (append-text info (wrap-as (i386:jump break-label))))
1750                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1751            (clone info
1752                   #:locals locals)))
1753
1754         ((if ,test ,then ,else)
1755          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
1756                 (here (number->string (length text)))
1757                 (label (string-append (.function info) "_" here "_"))
1758                 (break-label (string-append label "break"))
1759                 (else-label (string-append label "else"))
1760                 (info ((test-jump-label->info info else-label) test))
1761                 (info ((ast->info info) then))
1762                 (info (append-text info (wrap-as (i386:jump break-label))))
1763                 (info (append-text info (wrap-as `((#:label ,else-label)))))
1764                 (info ((ast->info info) else))
1765                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1766            (clone info
1767                   #:locals locals)))
1768
1769         ;; Hmm?
1770         ((expr-stmt (cond-expr ,test ,then ,else))
1771          (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
1772                 (here (number->string (length text)))
1773                 (label (string-append (.function info) "_" here "_"))
1774                 (else-label (string-append label "else"))
1775                 (break-label (string-append label "break"))
1776                 (info ((test-jump-label->info info else-label) test))
1777                 (info ((ast->info info) then))
1778                 (info (append-text info (wrap-as (i386:jump break-label))))
1779                 (info (append-text info (wrap-as `((#:label ,else-label)))))
1780                 (info ((ast->info info) else))
1781                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1782            info))
1783
1784         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1785          (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
1786                 (here (number->string (length text)))
1787                 (label (string-append (.function info) "_" here "_"))
1788                 (break-label (string-append label "break"))
1789                 (clauses (statements->clauses statements))
1790                 (info ((expr->accu info) expr))
1791                 (info (clone info #:break (cons break-label (.break info))))
1792                 (info (let loop ((clauses clauses) (i 0) (info info))
1793                         (if (null? clauses) info
1794                             (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
1795                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1796            (clone info
1797                   #:locals locals
1798                   #:break (cdr (.break info)))))
1799
1800         ((for ,init ,test ,step ,body)
1801          (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
1802                 (here (number->string (length text)))
1803                 (label (string-append (.function info) "_" here "_"))
1804                 (break-label (string-append label "break"))
1805                 (loop-label (string-append label "loop"))
1806                 (continue-label (string-append label "continue"))
1807                 (initial-skip-label (string-append label "initial_skip"))
1808                 (info ((ast->info info) init))
1809                 (info (clone info #:break (cons break-label (.break info))))
1810                 (info (clone info #:continue (cons continue-label (.continue info))))
1811                 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
1812                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
1813                 (info ((ast->info info) body))
1814                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
1815                 (info ((expr->accu info) step))
1816                 (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
1817                 (info ((test-jump-label->info info break-label) test))
1818                 (info (append-text info (wrap-as (i386:jump loop-label))))
1819                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1820            (clone info
1821                   #:locals locals
1822                   #:break (cdr (.break info))
1823                   #:continue (cdr (.continue info)))))
1824
1825         ((while ,test ,body)
1826          (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
1827                 (here (number->string (length text)))
1828                 (label (string-append (.function info) "_" here "_"))
1829                 (break-label (string-append label "break"))
1830                 (loop-label (string-append label "loop"))
1831                 (continue-label (string-append label "continue"))
1832                 (info (append-text info (wrap-as (i386:jump continue-label))))
1833                 (info (clone info #:break (cons break-label (.break info))))
1834                 (info (clone info #:continue (cons continue-label (.continue info))))
1835                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
1836                 (info ((ast->info info) body))
1837                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
1838                 (info ((test-jump-label->info info break-label) test))
1839                 (info (append-text info (wrap-as (i386:jump loop-label))))
1840                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1841            (clone info
1842                   #:locals locals
1843                   #:break (cdr (.break info))
1844                   #:continue (cdr (.continue info)))))
1845
1846         ((do-while ,body ,test)
1847          (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
1848                 (here (number->string (length text)))
1849                 (label (string-append (.function info) "_" here "_"))
1850                 (break-label (string-append label "break"))
1851                 (loop-label (string-append label "loop"))
1852                 (continue-label (string-append label "continue"))
1853                 (info (clone info #:break (cons break-label (.break info))))
1854                 (info (clone info #:continue (cons continue-label (.continue info))))
1855                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
1856                 (info ((ast->info info) body))
1857                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
1858                 (info ((test-jump-label->info info break-label) test))
1859                 (info (append-text info (wrap-as (i386:jump loop-label))))
1860                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1861            (clone info
1862                   #:locals locals
1863                   #:break (cdr (.break info))
1864                   #:continue (cdr (.continue info)))))
1865
1866         ((labeled-stmt (ident ,label) ,statement)
1867          (let ((info (append-text info `(((#:label ,(string-append (.function info) "_label_" label)))))))
1868            ((ast->info info) statement)))
1869
1870         ((goto (ident ,label))
1871          (append-text info (wrap-as (i386:jump (string-append (.function info) "_label_" label)))))
1872
1873         ((return ,expr)
1874          (let ((info ((expr->accu info) expr)))
1875            (append-text info (append (wrap-as (i386:ret))))))
1876
1877         ((decl . ,decl)
1878          ((decl->info info) o))
1879
1880         ;; ...
1881         ((gt . _) ((expr->accu info) o))
1882         ((ge . _) ((expr->accu info) o))
1883         ((ne . _) ((expr->accu info) o))
1884         ((eq . _) ((expr->accu info) o))
1885         ((le . _) ((expr->accu info) o))
1886         ((lt . _) ((expr->accu info) o))
1887         ((lshift . _) ((expr->accu info) o))
1888         ((rshift . _) ((expr->accu info) o))
1889
1890         ;; EXPR
1891         ((expr-stmt ,expression)
1892          (let ((info ((expr->accu info) expression)))
1893            (append-text info (wrap-as (i386:accu-zero?)))))
1894
1895         ;; FIXME: why do we get (post-inc ...) here
1896         ;; (array-ref
1897         (_ (let ((info ((expr->accu info) o)))
1898              (append-text info (wrap-as (i386:accu-zero?)))))))))
1899
1900 (define (enum-def-list->constants constants fields)
1901   (let loop ((fields fields) (i 0) (constants constants))
1902     (if (null? fields) constants
1903         (let* ((field (car fields))
1904                (name (pmatch field
1905                        ((enum-defn (ident ,name) . _) name)))
1906                (i (pmatch field
1907                     ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
1908                     ((enum-defn ,name) i)
1909                     ((enum-defn ,name (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))
1910                      (+ (cstring->number a) (cstring->number b)))
1911                     ((enum-defn ,name (sub (p-expr (fixed ,a)) (p-expr (fixed ,b))))
1912                      (- (cstring->number a) (cstring->number b)))
1913                     (_ (error "not supported enum field=~s\n" field)))))
1914           (loop (cdr fields)
1915                 (1+ i)
1916                 (append constants (list (ident->constant name i))))))))
1917
1918 (define (initzer->non-const info)
1919   (lambda (o)
1920     (pmatch o
1921       ((initzer (p-expr (ident ,name)))
1922        (let ((value (assoc-ref (.constants info) name)))
1923          `(initzer (p-expr (fixed ,(number->string value))))))
1924       (_ o))))
1925
1926 (define (initzer->data info)
1927   (lambda (o)
1928     (pmatch o
1929       ((initzer (p-expr (ident ,name)))
1930        (let ((value (assoc-ref (.constants info) name)))
1931          (int->bv32 (or value 0))))
1932       ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1933       ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1934       ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
1935       ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
1936       ((initzer (p-expr (string . ,strings))) `((#:string ,(string-join strings "")) #f #f #f))
1937       ((initzer (initzer-list . ,initzers)) (append-map (initzer->data info) initzers))
1938       (() (int->bv32 0))
1939       (_ (error "initzer->data: unsupported: " o)))))
1940
1941 (define (initzer->accu info)
1942   (lambda (o)
1943     (pmatch o
1944       ((initzer-list . ,initzers) (append-map (expr->accu info) initzers))
1945       ((initzer (initzer-list . ,initzers)) (append-map (expr->accu info) initzers))
1946       ((initzer ,initzer) ((expr->accu info) o))
1947       (() (append-text info (wrap-as (i386:value->accu 0))))
1948       (_ (error "initzer->accu: " o)))))
1949
1950 (define (expr->global globals)
1951   (lambda (o)
1952     (pmatch o
1953       ((p-expr (string ,string))
1954        (let ((g `(#:string ,string)))
1955          (or (assoc g globals)
1956              (string->global-entry string))))
1957       ((p-expr (string . ,strings))
1958        (let* ((string (string-join strings ""))
1959               (g `(#:string ,string)))
1960          (or (assoc g globals)
1961              (string->global-entry string))))
1962       ;;((p-expr (fixed ,value)) (int->global-entry (cstring->number value)))
1963       (_ #f))))
1964
1965 (define (initzer->globals globals)
1966   (lambda (o)
1967     (pmatch o
1968       ((initzer (initzer-list . ,initzers)) (append-map (initzer->globals globals) initzers))
1969       ((initzer ,initzer) (list ((expr->global globals) initzer)))
1970       (_ '(#f)))))
1971
1972 (define (type->info info o)
1973   (pmatch o
1974     ((struct-def (ident ,name) (field-list . ,fields))
1975      (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1976        (clone info #:types (cons type-entry (.types info)))))
1977     (_  info)))
1978
1979 (define (.formals o)
1980   (pmatch o
1981     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1982     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1983     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
1984     (_ (error ".formals: " o))))
1985
1986 (define (formal->text n)
1987   (lambda (o i)
1988     ;;(i386:formal i n)
1989     '()
1990     ))
1991
1992 (define (formals->text o)
1993   (pmatch o
1994     ((param-list . ,formals)
1995      (let ((n (length formals)))
1996        (wrap-as (append (i386:function-preamble)
1997                         (append-map (formal->text n) formals (iota n))
1998                         (i386:function-locals)))))
1999     (_ (error "formals->text: unsupported: " o))))
2000
2001 (define (formal:ptr o)
2002   (pmatch o
2003     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2004      0)
2005     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2006      2)
2007     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2008      1)
2009     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2010      1)
2011     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2012      2)
2013     (_ 0)))
2014
2015 (define (formals->locals o)
2016   (pmatch o
2017     ((param-list . ,formals)
2018      (let ((n (length formals)))
2019        (map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2020     (_ (error "formals->locals: unsupported: " o))))
2021
2022 (define (function->info info)
2023   (lambda (o)
2024     (define (assert-return text)
2025       (let ((return (wrap-as (i386:ret))))
2026         (if (equal? (list-tail text (- (length text) (length return))) return) text
2027             (append text return))))
2028     (let* ((name (.name o))
2029            (formals (.formals o))
2030            (text (formals->text formals))
2031            (locals (formals->locals formals)))
2032       (format (current-error-port) "    :~a\n" name)
2033       (let loop ((statements (.statements o))
2034                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2035         (if (null? statements) (clone info
2036                                       #:function #f
2037                                       #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2038             (let* ((statement (car statements)))
2039               (loop (cdr statements)
2040                     ((ast->info info) (car statements)))))))))
2041
2042 (define (ast-list->info info)
2043   (lambda (elements)
2044     (let loop ((elements elements) (info info))
2045       (if (null? elements) info
2046           (loop (cdr elements) ((ast->info info) (car elements)))))))
2047
2048 (define* (c99-input->info #:key (defines '()) (includes '()))
2049   (lambda ()
2050     (let* ((info (make <info> #:types i386:type-alist))
2051            (foo (stderr "parsing: input\n"))
2052            (ast (c99-input->ast #:defines defines #:includes includes))
2053            (foo (stderr "compiling: input\n"))
2054            (info ((ast->info info) ast))
2055            (info (clone info #:text '() #:locals '())))
2056       info)))
2057
2058 (define* (info->object o)
2059   `((functions . ,(.functions o))
2060     (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2061
2062 (define* (c99-ast->info ast)
2063   ((ast->info (make <info> #:types i386:type-alist)) ast))
2064
2065 (define* (c99-input->elf #:key (defines '()) (includes '()))
2066   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2067
2068 (define* (c99-input->object #:key (defines '()) (includes '()))
2069   ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))