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