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