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