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