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