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