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