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