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