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