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