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