mescc: Tinycc support: pointer arithmetic.
[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)))))
928              ((de-ref ,expr)
929               (let ((info ((expr->base info) expr)))
930                 (append-text info (wrap-as (i386:mem->base))))) ;; FIXME: size
931              ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
932               (let* ((info (append-text info (wrap-as (i386:push-accu))))
933                      (info ((expr->accu* info) a))
934                      (info (append-text info (wrap-as (i386:pop-base)))))
935                 (append-text info (wrap-as (i386:base->accu-address)))))
936              ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
937               (let* ((info (append-text info (wrap-as (i386:push-accu))))
938                      (info ((expr->accu* info) a))
939                      (info (append-text info (wrap-as (i386:pop-base)))))
940                 (append-text info (wrap-as (i386:base->accu-address)))))
941              ((array-ref ,index (p-expr (ident ,array)))
942               (let* ((type (ident->type info array))
943                      (size (ast-type->size info type))
944                      (info (append-text info (wrap-as (i386:push-accu))))
945                      (info ((expr->accu* info) a))
946                      (info (append-text info (wrap-as (i386:pop-base)))))
947                 (append-text info
948                              (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
949                                          (if (<= size 4) (wrap-as (i386:base->accu-address))
950                                           (append
951                                            (wrap-as (i386:base-address->accu-address))
952                                            (wrap-as (append (i386:accu+value 4)
953                                                             (i386:base+value 4)
954                                                             (i386:base-address->accu-address)))
955                                            (if (<= size 8) '()
956                                                (wrap-as (append (i386:accu+value 4)
957                                                                 (i386:base+value 4)
958                                                                 (i386:base-address->accu-address)))))))))))
959
960              ((i-sel (ident ,field) ,array)
961               (let* ((info (append-text info (wrap-as (i386:push-accu))))
962                      (info ((expr->accu* info) a))
963                      (info (append-text info (wrap-as (i386:pop-base)))))
964                 (append-text info (wrap-as (i386:base->accu-address)))))
965
966              (_ (error "expr->accu: unsupported assign: " a)))))
967
968         (_ (error "expr->accu: unsupported: " o))))))
969
970 (define (expr->base info)
971   (lambda (o)
972     (let* ((info (append-text info (wrap-as (i386:push-accu))))
973            (info ((expr->accu info) o))
974            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
975       info)))
976
977 (define (binop->accu info)
978   (lambda (a b c)
979     (let* ((info ((expr->accu info) a))
980            (info ((expr->base info) b)))
981       (append-text info (wrap-as c)))))
982
983 (define (wrap-as o . annotation)
984   `(,@annotation ,o))
985
986 (define (make-comment o)
987   (wrap-as `((#:comment ,o))))
988
989 (define (ast->comment o)
990   (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
991     (make-comment (string-join (string-split source #\newline) " "))))
992
993 (define (expr->accu* info)
994   (lambda (o)
995     (pmatch o
996       ;; g_cells[<expr>]
997       ((array-ref ,index (p-expr (ident ,array)))
998        (let* ((info ((expr->accu info) index))
999               (type (ident->type info array))
1000               (ptr (ident->pointer info array))
1001               (size (if (or (= ptr 1) (= ptr -1)) (ast-type->size info type)
1002                         4)))
1003          (append-text info (append (wrap-as (append (i386:accu->base)
1004                                                     (if (eq? size 1) '()
1005                                                         (append
1006                                                          (if (<= size 4) '()
1007                                                              (i386:accu+accu))
1008                                                          (if (<= size 8) '()
1009                                                              (i386:accu+base))
1010                                                          (i386:accu-shl 2)))))
1011                                    ((ident->base info) array)
1012                                    (wrap-as (i386:accu+base))))))
1013
1014       ;; bar.foo.i
1015       ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1016        (let* ((type0 (ident->type info struct0))
1017               (type1 (field-type info type0 field0))
1018               (offset (+ (field-offset info type0 field0)
1019                          (field-offset info type1 field1))))
1020          (append-text info (append ((ident->accu info) struct0)
1021                                    (wrap-as (i386:accu+value offset))))))
1022
1023       ;; bar.poo->i
1024       ((i-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1025        (let* ((type0 (ident->type info struct0))
1026               (type1 (field-type info type0 field0))
1027               (offset0 (field-offset info type0 field0))
1028               (offset1 (field-offset info type1 field1)))
1029          (append-text info (append ((ident->accu info) struct0)
1030                                    (wrap-as (i386:accu+value offset0))
1031                                    (wrap-as (i386:mem->accu))
1032                                    (wrap-as (i386:accu+value offset1))))))
1033
1034       ;; bar->foo.i
1035       ((d-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0))))
1036        (let* ((type0 (ident->type info struct0))
1037               (type1 (field-type info type0 field0))
1038               (offset (+ (field-offset info type0 field0)
1039                          (field-offset info type1 field1))))
1040          (append-text info (append ((ident-address->accu info) struct0)
1041                                    (wrap-as (i386:accu+value offset))))))
1042
1043       ;; bar->foo.i
1044       ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1045        (let* ((type0 (ident->type info struct0))
1046               (type1 (field-type info type0 field0))
1047               (offset (+ (field-offset info type0 field0)
1048                          (field-offset info type1 field1))))
1049          (append-text info (append ((ident->accu info) struct0)
1050                                    (wrap-as (i386:accu+value offset))))))
1051
1052       ;;(i-sel (ident "i") (i-sel (ident "p") (p-expr (ident "p"))))
1053       ((i-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0))))
1054        (let* ((type0 (ident->type info struct0))
1055               (type1 (field-type info type0 field0))
1056               (offset0 (field-offset info type0 field0))
1057               (offset1 (field-offset info type1 field1)))
1058          (append-text info (append ((ident->accu info) struct0)
1059                                    (wrap-as (i386:accu+value offset0))
1060                                    (wrap-as (i386:mem->accu))
1061                                    (wrap-as (i386:accu+value offset1))))))
1062
1063       ;; (*pp)->bar.foo
1064       ((d-sel (ident ,field1) (i-sel (ident ,field0) (de-ref (p-expr (ident ,struct0)))))
1065        (let* ((type0 (ident->type info struct0))
1066               (type1 (field-type info type0 field0))
1067               (offset (+ (field-offset info type0 field0)
1068                          (field-offset info type1 field1))))
1069          (append-text info (append ((ident->accu info) struct0)
1070                                    (wrap-as (i386:mem->accu))
1071                                    (wrap-as (i386:accu+value offset))))))
1072
1073       ;; g_cells[<expr>].type
1074       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
1075        (let* ((type (ident->type info array))
1076               (offset (field-offset info type field))
1077               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1078          (append-text info (wrap-as (i386:accu+value offset)))))
1079
1080       ;; foo.bar
1081       ((d-sel (ident ,field) (p-expr (ident ,struct)))
1082        (let* ((type (ident->type info struct))
1083               (offset (field-offset info type field))
1084               (text (.text info))
1085               (ptr (field-pointer info type field)))
1086          (if (= ptr -1)
1087              (append-text info (append ((ident-address->accu info) struct)
1088                                        (wrap-as (i386:accu+value offset))))
1089              (append-text info (append ((ident->accu info) struct)
1090                                        (wrap-as (i386:accu+value offset)))))))
1091
1092       ;; foo.bar[baz]
1093       ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
1094        (let* ((type (ident->type info struct))
1095               (offset (field-offset info type field))
1096               (info ((expr->accu info) index)))
1097          (append-text info (append (wrap-as (append (i386:accu-shl 2) ;; FIXME: assume size=4
1098                                                     (i386:push-accu)))
1099                                    ((ident-address->accu info) struct)
1100                                    (wrap-as (append (i386:accu+value offset)
1101                                                     (i386:pop-base)
1102                                                     (i386:accu+base)))))))
1103
1104       ;; foo->bar[baz]
1105       ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
1106        (let* ((type (ident->type info struct))
1107               (offset (field-offset info type field))
1108               (info ((expr->accu info) index)))
1109          (append-text info (append (wrap-as (append (i386:accu-shl 2) ;; FIXME: assume size=4
1110                                                     (i386:push-accu)))
1111                                    ((ident->accu info) struct)
1112                                    (wrap-as (append (i386:accu+value offset)
1113                                                     (i386:pop-base)
1114                                                     (i386:accu+base)))))))
1115       
1116       ((array-ref ,index ,array)
1117        (let* ((info ((expr->accu info) index))
1118               (size 4) ;; FIXME
1119               (info (append-text info (wrap-as (append (i386:accu->base)
1120                                                        (if (eq? size 1) '()
1121                                                            (append
1122                                                             (if (<= size 4) '()
1123                                                                 (i386:accu+accu))
1124                                                             (if (<= size 8) '()
1125                                                                 (i386:accu+base))
1126                                                             (i386:accu-shl 2)))))))
1127               (info ((expr->base info) array)))
1128           (append-text info (wrap-as (i386:accu+base)))))
1129
1130       ((i-sel (ident ,field) (p-expr (ident ,array)))
1131        (let* ((type (ident->type info array))
1132               (offset (field-offset info type field)))
1133          (append-text info (append ((ident-address->accu info) array)
1134                                    (wrap-as (i386:mem->accu))
1135                                    (wrap-as (i386:accu+value offset))))))
1136
1137       ((i-sel (ident ,field) (de-ref (p-expr (ident ,array))))
1138        (let* ((type (ident->type info array))
1139               (offset (field-offset info type field)))
1140          (append-text info (append ((ident-address->accu info) array)
1141                                    (wrap-as (i386:mem->accu))
1142                                    (wrap-as (i386:mem->accu))
1143                                    (wrap-as (i386:accu+value offset))))))
1144
1145       ;; foo[i].bar.baz
1146       ((d-sel (ident ,field1) (d-sel (ident ,field0) (array-ref ,index (p-expr (ident ,array)))))
1147          (let* ((type0 (ident->type info array))
1148                 (type1 (field-type info type0 field0))
1149                 (offset (+ (field-offset info type0 field0)
1150                            (field-offset info type1 field1)))
1151                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1152            (append-text info (wrap-as (i386:accu+value offset)))))
1153
1154       ;;foo[index]->bar
1155       ((i-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
1156        (let* ((type (ident->type info array))
1157               (offset (field-offset info type field))
1158               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1159          (append-text info (append (wrap-as (i386:mem->accu))
1160                                    (wrap-as (i386:mem->accu))
1161                                    (wrap-as (i386:accu+value offset))))))
1162
1163       (_ (error "expr->accu*: unsupported: " o)))))
1164
1165 (define (ident->constant name value)
1166   (cons name value))
1167
1168 (define (enum->type-entry name fields)
1169   (cons `("tag" ,name) (make-type 'enum 4 0 fields)))
1170
1171 (define (struct->type-entry name fields)
1172   (cons `("tag" ,name) (make-type 'struct (apply + (map field:size fields)) 0 fields)))
1173
1174 (define (union->type-entry name fields)
1175   (cons `("tag" ,name) (make-type 'union (apply + (map field:size fields)) 0 fields)))
1176
1177 (define i386:type-alist
1178   `(("char" . ,(make-type 'builtin 1 0 #f))
1179     ("short" . ,(make-type 'builtin 2 0 #f))
1180     ("int" . ,(make-type 'builtin 4 0 #f))
1181     ("long" . ,(make-type 'builtin 4 0 #f))
1182     ("long long" . ,(make-type 'builtin 8 0 #f))
1183     ("long long int" . ,(make-type 'builtin 8 0 #f))
1184     ("void" . ,(make-type 'builtin 1 0 #f))
1185     ;; FIXME sign
1186     ("unsigned char" . ,(make-type 'builtin 1 0 #f))
1187     ("unsigned short" . ,(make-type 'builtin 2 0 #f))
1188     ("unsigned short int" . ,(make-type 'builtin 2 0 #f))
1189     ("unsigned" . ,(make-type 'builtin 4 0 #f))
1190     ("unsigned int" . ,(make-type 'builtin 4 0 #f))
1191     ("unsigned long" . ,(make-type 'builtin 4 0 #f))
1192     ("unsigned long long" . ,(make-type 'builtin 8 0 #f))
1193     ("unsigned long long int" . ,(make-type 'builtin 8 0 #f))))
1194
1195 (define (field:name o)
1196   (pmatch o
1197     ((union (,name ,type ,size ,pointer) . ,rest) name)
1198     ;;((union (,name ,type ,size) . ,rest) name)
1199     ((,name ,type ,size ,pointer) name)
1200     ;;((,name ,type ,size) name)
1201     (_ (error "field:name not supported:" o))))
1202
1203 (define (field:pointer o)
1204   (pmatch o
1205     ((union (,name ,type ,size ,pointer) . ,rest) pointer)
1206     ((,name ,type ,size ,pointer) pointer)
1207     (_ (error "field:name not supported:" o))))
1208
1209 (define (field:size o)
1210   (pmatch o
1211     ((union . ,fields) 4) ;; FIXME
1212     ((,name ,type ,size ,pointer) size)
1213     ;;((,name ,type ,size) size)
1214     (_ 4)))
1215
1216 (define (field:type o)
1217   (pmatch o
1218     ((,name ,type ,size ,pointer) type)
1219     ;;((,name ,type ,size) type)
1220     (_ (error "field:type:" o))))
1221
1222 (define (get-type types o)
1223   (let ((t (assoc-ref types o)))
1224     (pmatch t
1225       ((typedef ,next) (get-type types next))
1226       (_ t))))
1227
1228 (define (ast-type->type info o)
1229   (pmatch o
1230     ((p-expr ,expr) (ast-type->type info (p-expr->type info o)))
1231     ((decl-spec-list (type-spec (fixed-type ,type)))
1232      (ast-type->type info type))
1233     ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
1234      (ast-type->type info type))
1235     ((struct-ref (ident (,type)))
1236      (let ((struct (if (pair? type) type `("tag" ,type))))
1237        (ast-type->type info struct)))
1238     ((struct-ref (ident ,type))
1239      (let ((struct (if (pair? type) type `("tag" ,type))))
1240        (ast-type->type info struct)))
1241     ((union-ref (ident ,type))
1242      (let ((struct (if (pair? type) type `("tag" ,type))))
1243        (ast-type->type info struct)))
1244     ((void) (ast-type->type info "void"))
1245     ((type-spec ,type) (ast-type->type info type))
1246     ((fixed-type ,type) (ast-type->type info type))
1247     ((typename ,type) (ast-type->type info type))
1248     (_ (let ((type (get-type (.types info) o)))
1249          (if type type
1250              (begin
1251                (stderr "types: ~s\n" (.types info))
1252                (error "ast-type->type: unsupported: " o)))))))
1253
1254 (define (ast-type->description info o)
1255   (let ((type (ast-type->type info o)))
1256     (type:description type)))
1257
1258 (define (ast-type->size info o)
1259   (let ((type (ast-type->type info o)))
1260     (type:size type)))
1261
1262 (define (field-field info struct field)
1263   (let* ((xtype (ast-type->type info struct))
1264          (fields (type:description xtype)))
1265     (let loop ((fields fields))
1266       (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
1267           (let ((f (car fields)))
1268             (cond ((equal? (car f) field) f)
1269                   ((and (eq? (car f) 'union)
1270                         (find (lambda (x) (equal? (car x) field)) (cdr f))))
1271                   (else (loop (cdr fields)))))))))
1272
1273 (define (field-offset info struct field)
1274   (let ((xtype (ast-type->type info struct)))
1275     (if (eq? (type:type xtype) 'union) 0
1276         (let ((fields (type:description xtype)))
1277           (let loop ((fields fields) (offset 0))
1278             (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
1279                 (let ((f (car fields)))
1280                   (cond ((equal? (car f) field) offset)
1281                         ((and (eq? (car f) 'union)
1282                               (find (lambda (x) (equal? (car x) field)) (cdr f))
1283                               offset))
1284                         (else (loop (cdr fields) (+ offset (field:size f))))))))))))
1285
1286 (define (field-pointer info struct field)
1287   (let ((xtype (ast-type->type info struct)))
1288     (let ((field (field-field info struct field)))
1289       (field:pointer field))))
1290
1291 (define (field-size info struct field)
1292   (let ((xtype (ast-type->type info struct)))
1293     (if (eq? (type:type xtype) 'union) 0
1294         (let ((field (field-field info struct field)))
1295           (field:size field)))))
1296
1297 (define (field-type info struct field)
1298   (let ((xtype (ast-type->type info struct)))
1299     (let ((field (field-field info struct field)))
1300       (field:type field))))
1301
1302 (define (ast->type o)
1303   (pmatch o
1304     ((fixed-type ,type)
1305      type)
1306     ((typename ,type)
1307      type)
1308     ((struct-ref (ident (,type)))
1309      `("tag" ,type))
1310     ((struct-ref (ident ,type))
1311      `("tag" ,type))
1312     (_ (stderr "SKIP: type=~s\n" o)
1313        "int")))
1314
1315 (define (decl->ast-type o)
1316   (pmatch o
1317     ((fixed-type ,type) type)
1318     ((struct-ref (ident (,name))) `("tag" ,name))
1319     ((struct-ref (ident ,name)) `("tag" ,name))
1320     ((struct-def (ident ,name) . ,fields) `("tag" ,name))
1321     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm"
1322      `("tag" ,name)) ;; FIXME
1323     ((typename ,name) name)
1324     (,name name)
1325     (_ (error "decl->ast-type: unsupported: " o))))
1326
1327 (define (byte->hex.m1 o)
1328   (string-drop o 2))
1329
1330 (define (asm->m1 o)
1331   (let ((prefix ".byte "))
1332     (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
1333         (let ((s (string-drop o (string-length prefix))))
1334           (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
1335
1336 (define (clause->info info i label last?)
1337   (define clause-label
1338     (string-append label "clause" (number->string i)))
1339   (define body-label
1340     (string-append label "body" (number->string i)))
1341   (define (jump label)
1342     (wrap-as (i386:jump label)))
1343   (define (jump-nz label)
1344     (wrap-as (i386:jump-nz label)))
1345   (define (jump-z label)
1346     (wrap-as (i386:jump-z label)))
1347   (define (test->text test)
1348     (let ((value (pmatch test
1349                    (0 0)
1350                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
1351                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1352                    ((p-expr (fixed ,value)) (cstring->number value))
1353                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1354                    (_ (error "case test: unsupported: " test)))))
1355       (append (wrap-as (i386:accu-cmp-value value))
1356               (jump-z body-label))))
1357   (define (cases+jump info cases)
1358     (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
1359            (next-clause-label (if last? (string-append label "break")
1360                                   (string-append label "clause" (number->string (1+ i)))))
1361            (info (append-text info (apply append cases)))
1362            (info (if (null? cases) info
1363                      (append-text info (jump next-clause-label))))
1364            (info (append-text info (wrap-as `((#:label ,body-label))))))
1365       info))
1366
1367   (lambda (o)
1368     (let loop ((o o) (cases '()) (clause #f))
1369       (pmatch o
1370         ((case ,test ,statement)
1371          (loop statement (append cases (list (test->text test))) clause))
1372         ((default ,statement)
1373          (loop statement cases clause))
1374         ((default . ,statements)
1375          (loop `(compd-stmt (block-item-list ,@statements)) cases clause))
1376         ((compd-stmt (block-item-list))
1377          (loop '() cases clause))
1378         ((compd-stmt (block-item-list . ,elements))
1379          (let ((clause (or clause (cases+jump info cases))))
1380            (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1381                  ((ast->info clause) (car elements)))))
1382         (()
1383          (let ((clause (or clause (cases+jump info cases))))
1384            (if last? clause
1385                (let ((next-body-label (string-append label "body"
1386                                                      (number->string (1+ i)))))
1387                  (append-text clause (wrap-as (i386:jump next-body-label)))))))
1388         (_
1389          (let ((clause (or clause (cases+jump info cases))))
1390            (loop '() cases
1391                  ((ast->info clause) o))))))))
1392
1393 (define (test-jump-label->info info label)
1394   (define (jump type . test)
1395     (lambda (o)
1396       (let* ((info ((ast->info info) o))
1397              (info (append-text info (make-comment "jmp test LABEL")))
1398              (jump-text (wrap-as (type label))))
1399         (append-text info (append (if (null? test) '() (car test))
1400                                   jump-text)))))
1401   (lambda (o)
1402     (pmatch o
1403       ;; unsigned
1404       ;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
1405       ;; ((lt ,a ,b) ((jump i386:jump-nc) o))  ; jae
1406       ;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
1407       ;; ((gt ,a ,b) ((jump i386:jump-nc) o))
1408
1409       ((le ,a ,b) ((jump i386:jump-g) o))
1410       ((lt ,a ,b) ((jump i386:jump-ge) o))
1411       ((ge ,a ,b) ((jump i386:jump-g) o))
1412       ((gt ,a ,b) ((jump i386:jump-ge) o))
1413
1414       ((ne ,a ,b) ((jump i386:jump-nz) o))
1415       ((eq ,a ,b) ((jump i386:jump-nz) o))
1416       ((not _) ((jump i386:jump-z) o))
1417
1418       ((and ,a ,b)
1419        (let* ((info ((test-jump-label->info info label) a))
1420               (info ((test-jump-label->info info label) b)))
1421          info))
1422
1423       ((or ,a ,b)
1424        (let* ((here (number->string (length (.text info))))
1425               (skip-b-label (string-append label "_skip_b_" here))
1426               (b-label (string-append label "_b_" here))
1427               (info ((test-jump-label->info info b-label) a))
1428               (info (append-text info (wrap-as (i386:jump skip-b-label))))
1429               (info (append-text info (wrap-as `((#:label ,b-label)))))
1430               (info ((test-jump-label->info info label) b))
1431               (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1432          info))
1433
1434       ((array-ref ,index ,expr) (let* ((ptr (expr->pointer info expr))
1435                                        (size (if (= ptr 1) (ast-type->size info expr)
1436                                                  4)))
1437                                   ((jump (if (= size 1) i386:jump-byte-z
1438                                              i386:jump-z)
1439                                          (wrap-as (i386:accu-zero?))) o)))
1440
1441       ((de-ref ,expr) (let* ((ptr (expr->pointer info expr))
1442                              (size (if (= ptr 1) (ast-type->size info expr)
1443                                        4)))
1444                         ((jump (if (= size 1) i386:jump-byte-z
1445                                    i386:jump-z)
1446                                (wrap-as (i386:accu-zero?))) o)))
1447
1448       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1449        ((jump i386:jump-z
1450               (append ((ident->accu info) name)
1451                       (wrap-as (i386:accu-zero?)))) o))
1452
1453       (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
1454
1455 (define (cstring->number s)
1456   (let ((s (cond ((string-suffix? "ULL" s) (string-drop-right s 3))
1457                  ((string-suffix? "UL" s) (string-drop-right s 2))
1458                  ((string-suffix? "LL" s) (string-drop-right s 2))
1459                  ((string-suffix? "L" s) (string-drop-right s 1))
1460                  (else s))))
1461     (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1462           ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1463           ((string-prefix? "0" s) (string->number s 8))
1464           (else (string->number s)))))
1465
1466 (define (p-expr->number info o)
1467   (pmatch o
1468     ((p-expr (fixed ,a))
1469      (cstring->number a))
1470     ((neg ,a)
1471      (- (p-expr->number info a)))
1472     ((add ,a ,b)
1473      (+ (p-expr->number info a) (p-expr->number info b)))
1474     ((bitwise-or ,a ,b)
1475      (logior (p-expr->number info a) (p-expr->number info b)))
1476     ((div ,a ,b)
1477      (quotient (p-expr->number info a) (p-expr->number info b)))
1478     ((mul ,a ,b)
1479      (* (p-expr->number info a) (p-expr->number info b)))
1480     ((sub ,a ,b)
1481      (- (p-expr->number info a) (p-expr->number info b)))
1482     ((sizeof-type (type-name (decl-spec-list (type-spec ,type))))
1483      (ast-type->size info type))
1484     ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
1485      (let ((type (ident->type info struct)))
1486        (field-size info type field)))
1487     ((p-expr (ident ,name))
1488      (let ((value (assoc-ref (.constants info) name)))
1489        (or value
1490            (error (format #f "p-expr->number: undeclared identifier: ~s\n" o)))))
1491     (_  (error (format #f "p-expr->number: not supported: ~s\n" o)))))
1492
1493 (define (struct-field info)
1494   (lambda (o)
1495     (pmatch o
1496       ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1497                   (comp-declr-list (comp-declr (ident ,name))))
1498        (list name `("tag" ,type) 4 0))
1499       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1500        (list name type 4 0))
1501       ((comp-decl (decl-spec-list (type-spec (typename ,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 (ptr-declr (pointer (pointer)) (ident ,name)))))
1504        (list name type 4 2))
1505       ((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)))))
1506        (list name type 4 1))
1507       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
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 (pointer)) (ident ,name)))))
1510        (list name type 4 2))
1511       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1512        (list name "void" 4 2))
1513       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1514        (list name "void" 4 1))
1515       ((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)))))
1516        (list name "void" 4 1))
1517       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1518        (list name type 4 1))
1519       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
1520        (let ((size 4)
1521              (count (p-expr->number info count)))
1522          (list name type (* count size) -1)))
1523       ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
1524        (let ((size (ast-type->size info type))
1525              (count (p-expr->number info count)))
1526          (list name type (* count size) -1)))
1527       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1528        (list name `("tag" ,type) 4 2))
1529
1530       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1531        (list name `("tag" ,type) 4 2))
1532
1533       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1534        (list name `("tag" ,type) 4 1))
1535
1536       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1537        (list name `("tag" ,type) 4 1))
1538
1539       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ident ,name))))
1540        ((struct-field info) `(comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))))
1541
1542       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1543        (let ((size (ast-type->size info `("tag" ,type))))
1544          (list name `("tag" ,type) size 0)))
1545
1546       ((comp-decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1547        (let ((size (ast-type->size info `("tag" ,type))))
1548          (list name `("tag" ,type) size 0)))
1549
1550       ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
1551        `(union ,@(map (struct-field info) fields)))
1552
1553       (_ (error "struct-field: unsupported: " o)))))
1554
1555 (define (ident->decl info o)
1556   (or (assoc-ref (.locals info) o)
1557       (assoc-ref (.globals info) o)
1558       (assoc-ref (.constants info) o)
1559       (begin
1560         (stderr "NO IDENT: ~a\n" o)
1561         (assoc-ref (.functions info) o))))
1562
1563 (define (ident->type info o)
1564   (let ((type (ident->decl info o)))
1565     (cond ((global? type) (global:type type))
1566           ((local? type) (local:type type))
1567           ((assoc-ref (.constants info) o) "int")
1568           (else (stderr "ident->type ~s => ~s\n" o type)
1569                 (car type)))))
1570
1571 (define (ident->pointer info o)
1572   (let ((local (assoc-ref (.locals info) o)))
1573     (if local (local:pointer local)
1574         (let ((global (assoc-ref (.globals info) o)))
1575           (if global
1576               (global:pointer (ident->decl info o))
1577               0)))))
1578
1579 (define (ident->size info o)
1580   (let* ((type (ident->type info o))
1581          (xtype (ast-type->type info type)))
1582     (type:size xtype)))
1583
1584 (define (expr->pointer info o)
1585   (pmatch o
1586     ((p-expr (ident ,name)) (ident->pointer info name))
1587     (_ (stderr "expr->pointer: unsupported: ~s\n" o) 0)))
1588
1589 (define (expr->size info o)
1590   (pmatch o
1591     ((p-expr (ident ,name)) (ident->size info name))
1592     (_ (stderr "expr->size: unsupported: ~s\n" o) 4)))
1593
1594 (define (p-expr->type info o)
1595   (pmatch o
1596     ((p-expr (ident ,name)) (ident->type info name))
1597     ((array-ref ,index (p-expr (ident ,array))) (ident->type info array))
1598     ((i-sel (ident ,field) (p-expr (ident ,struct)))
1599      (let ((type0 (ident->type info struct)))
1600        (field-type info `("tag" ,type0) field)))
1601     ((d-sel (ident ,field) (p-expr (ident ,struct)))
1602      (let ((type0 (ident->type info struct)))
1603        (field-type info `("tag" ,type0) field)))
1604     ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
1605      (let ((type0 (ident->type info array)))
1606        (field-type info `("tag" ,type0) field)))
1607     (_ (error "p-expr->type: unsupported: " o))))
1608
1609 (define (local-var? o) ;; formals < 0, locals > 0
1610   (positive? (local:id o)))
1611
1612 (define (ptr-declr->pointer o)
1613   (pmatch o
1614     ((pointer) 1)
1615     ((pointer (pointer)) 2)
1616     ((pointer (pointer (pointer))) 3)
1617     (_ (error "ptr-declr->pointer unsupported: " o))))
1618
1619 (define (init-declr->name o)
1620   (pmatch o
1621     ((ident ,name) name)
1622     ((ptr-declr ,pointer (ident ,name)) name)
1623     ((array-of (ident ,name)) name)
1624     ((array-of (ident ,name) ,index) name)
1625     ((ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)) name)
1626     ((ptr-declr (pointer) (array-of (ident ,name))) name)
1627     ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) name)
1628     (_ (error "init-declr->name unsupported: " o))))
1629
1630 (define (init-declr->pointer o)
1631   (pmatch o
1632     ((ident ,name) 0)
1633     ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer))
1634     ((array-of (ident ,name) ,index) -1)
1635     ((array-of (ident ,name)) -1)
1636     ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer))
1637     ((ptr-declr (pointer) (array-of (ident ,name))) -2)
1638     ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2)
1639     (_ (error "init-declr->pointer unsupported: " o))))
1640
1641 (define (statements->clauses statements)
1642   (let loop ((statements statements) (clauses '()))
1643     (if (null? statements) clauses
1644         (let ((s (car statements)))
1645           (pmatch s
1646             ((case ,test (compd-stmt (block-item-list . _)))
1647              (loop (cdr statements) (append clauses (list s))))
1648             ((case ,test (break))
1649              (loop (cdr statements) (append clauses (list s))))
1650             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1651
1652             ((case ,test ,statement)
1653              (let loop2 ((statement statement) (heads `((case ,test))))
1654                (define (heads->case heads statement)
1655                  (if (null? heads) statement
1656                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1657                (pmatch statement
1658                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1659                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1660                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1661                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1662                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1663                           (let ((s (car statements)))
1664                             (pmatch s
1665                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1666                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1667                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1668                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1669             ((default (compd-stmt (block-item-list _)))
1670              (loop (cdr statements) (append clauses (list s))))
1671             ((default . ,statement)
1672              (let loop2 ((statements (cdr statements)) (c statement))
1673                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1674                    (let ((s (car statements)))
1675                      (pmatch s
1676                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1677                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1678                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1679                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1680
1681                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1682             (_ (error "statements->clauses: unsupported:" s)))))))
1683
1684 (define (decl->info info)
1685   (lambda (o)
1686     (let ((functions (.functions info))
1687           (globals (.globals info))
1688           (locals (.locals info))
1689           (constants (.constants info))
1690           (types (.types info))
1691           (text (.text info)))
1692       (define (add-local locals name type pointer)
1693         (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
1694                        (1+ (local:id (cdar locals)))))
1695                (locals (cons (make-local-entry name type pointer id) locals)))
1696           locals))
1697       (define (declare name)
1698         (if (member name functions) info
1699             (clone info #:functions (cons (cons name #f) functions))))
1700       (pmatch o
1701
1702         ;; FIXME: Nyacc sometimes produces extra parens: (ident (<struct-name>))
1703         ((decl (decl-spec-list (stor-spec ,spec) (type-spec (struct-ref (ident (,type))))) ,init)
1704          ((decl->info info) `(decl (decl-spec-list (stor-spec ,spec) (type-spec (struct-ref (ident ,type)))) ,init)))
1705         ((decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1706          ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))))
1707
1708         ((decl (decl-spec-list (type-spec (struct-def (ident (,type)) ,field-list))))
1709          ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
1710
1711         ((decl (decl-spec-list (stor-spec ,spec) (type-spec (union-ref (ident (,type))))) ,init)
1712          ((decl->info info) `(decl (decl-spec-list (stor-spec ,spec) (type-spec (union-ref (ident ,type)))) ,init)))
1713         ((decl (decl-spec-list (type-spec (union-def (ident (,type)) ,field-list))))
1714          ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
1715
1716         ((decl (decl-spec-list (type-spec (union-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name) ,initzer)))
1717          ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name) ,initzer)))))
1718
1719
1720         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1721          (declare name))
1722
1723         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1724          (clone info #:types (cons (cons name (get-type types type)) types)))
1725
1726         ;; int foo ();
1727         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1728          (declare name))
1729
1730         ;; void foo ();
1731         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1732          (declare name))
1733
1734         ;; void foo (*);
1735         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1736          (declare name))
1737
1738         ;; char *strcpy ();
1739         ((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))))))
1740          (declare name))
1741
1742         ;; printf (char const* format, ...)
1743         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1744          (declare name))
1745
1746         ;; <name> tcc_new
1747         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1748          (declare name))
1749
1750         ;; extern type foo ()
1751         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1752          (declare name))
1753
1754         ;; struct TCCState;
1755         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
1756          info)
1757
1758         ;; extern type global;
1759         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
1760          info)
1761
1762         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ident ,name))))
1763          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ident ,name)))))
1764          info)
1765
1766         ;; extern foo *bar;
1767         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1768          info)
1769
1770         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1771          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))))
1772
1773         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
1774         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1775          info)
1776
1777         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
1778         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
1779          info)
1780
1781         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
1782         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1783          info)
1784
1785         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
1786         ;; Yay, let's hear it for the T-for Tiny in TCC!?
1787         ((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)))))
1788          info)
1789
1790         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1791          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
1792
1793         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1794          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
1795
1796         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1797          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
1798
1799         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1800          ((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))))))
1801
1802         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1803          ((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))))))
1804
1805         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1806          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
1807                 (types (.types info)))
1808            (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
1809
1810         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1811          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
1812                 (types (.types info)))
1813            (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
1814
1815         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1816          (let* ((type (get-type types type))
1817                 (type (make-type (type:type type)
1818                                  (type:size type)
1819                                  (1+ (type:pointer type))
1820                                  (type:description type)))
1821                 (type-entry (cons name type)))
1822            (clone info #:types (cons type-entry types))))
1823
1824         ;; struct
1825         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1826          (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1827            (clone info #:types (cons type-entry types))))
1828
1829         ;; enum e i;
1830         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1831          (let ((type "int")) ;; FIXME
1832            (if (.function info)
1833                (clone info #:locals (add-local locals name type 0))
1834                (clone info #:globals (append globals (list (ident->global-entry name type 0 0)))))))
1835
1836         ;; struct foo bar[2];
1837         ;; char arena[20000];
1838         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
1839          (let ((type (ast->type type)))
1840            (if (.function info)
1841                (let* ((local (car (add-local locals name type -1)))
1842                       (count (p-expr->number info count))
1843                       (size (ast-type->size info type))
1844                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))                      
1845                       (locals (cons local locals))
1846                       (info (clone info #:locals locals)))
1847                  info)
1848                (let* ((globals (.globals info))
1849                       (count (p-expr->number info count))
1850                       (size (ast-type->size info type))
1851                       (array (make-global-entry name type -1 (string->list (make-string (* count size) #\nul))))
1852                       (globals (append globals (list array))))
1853                  (clone info #:globals globals)))))
1854
1855         ((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))))))
1856          (if (.function info)
1857              (error  "TODO: " o)
1858              (let* ((globals (.globals info))
1859                     ;; (count (cstring->number count))
1860                     ;; (size (ast-type->size info type))
1861                     (array (make-global-entry array type -1 (string->list string)))
1862                     (globals (append globals (list array))))
1863                (clone info #:globals globals))))
1864
1865         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1866         ((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))))
1867          (let* ((locals (add-local locals name type 1))
1868                 (info (clone info #:locals locals))
1869                 (empty (clone info #:text '()))
1870                 (accu ((expr->accu empty) initzer)))
1871            (clone info
1872                   #:text
1873                   (append text
1874                           (.text accu)
1875                           ((accu->ident info) name)
1876                           (wrap-as (append (i386:label->base `(#:address "_start"))
1877                                            (i386:accu+base))))
1878                   #:locals locals)))
1879
1880         ;; char *p = g_cells;
1881         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1882          (let ((info (append-text info (ast->comment o)))
1883                (type (decl->ast-type type)))
1884            (if (.function info)
1885                (let* ((locals (add-local locals name type  1))
1886                       (info (clone info #:locals locals)))
1887                  (append-text info (append ((ident->accu info) value)
1888                                            ((accu->ident info) name))))
1889                (let ((globals (append globals (list (ident->global-entry name type 1 `(,value #f #f #f))))))
1890                  (clone info #:globals globals)))))
1891
1892         ;; enum foo { };
1893         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1894          (let ((type-entry (enum->type-entry name fields))
1895                (constants (enum-def-list->constants constants fields)))
1896            (clone info
1897                   #:types (cons type-entry types)
1898                   #:constants (append constants (.constants info)))))
1899
1900         ;; enum {};
1901         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1902          (let ((constants (enum-def-list->constants constants fields)))
1903            (clone info
1904                   #:constants (append constants (.constants info)))))
1905
1906         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1907          (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1908            (clone info #:types (cons type-entry types))))
1909
1910         ((decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))))
1911          (let ((type-entry (union->type-entry name (map (struct-field info) fields))))
1912            (clone info #:types (cons type-entry types))))
1913
1914         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1915                (init-declr-list (init-declr (ident ,name))))
1916          (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1917            ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1918
1919         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,fields))) (init-declr-list (init-declr (ident ,name))))
1920          (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,fields)))))))
1921            ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1922
1923         ;; struct f = {...};
1924         ;; LOCALS!
1925         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1926          (let* ((info (append-text info (ast->comment o)))
1927                 (type (decl->ast-type type))
1928                 (fields (ast-type->description info type))
1929                 (xtype (ast-type->type info type))
1930                 (fields (if (not (eq? (type:type xtype) 'union)) fields
1931                             (list-head fields 1)))
1932                 (size (ast-type->size info type))
1933                 (initzers (map (initzer->non-const info) initzers)))
1934            (if (.function info)
1935                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1936                       (global-names (map car globals))
1937                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1938                       (globals (append globals initzer-globals))
1939                       (local (car (add-local locals name type -1)))
1940                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) (quotient (+ size 3) 4))))
1941                       (locals (cons local locals))
1942                       (info (clone info #:locals locals #:globals globals))
1943                       (empty (clone info #:text '())))
1944                  (let loop ((fields fields) (initzers initzers) (info info))
1945                    (if (null? fields) info
1946                        (let ((offset (field-offset info type (field:name (car fields))))
1947                              (initzer (if (null? initzers) '(p-expr (fixed "0")) (car initzers))))
1948                          (loop (cdr fields) (if (null? initzers) '() (cdr initzers))
1949                                (clone info #:text
1950                                       (append
1951                                        (.text info)
1952                                        ((ident->accu info) name)
1953                                        (wrap-as (append (i386:accu->base)))
1954                                        (.text ((expr->accu empty) initzer))
1955                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1956                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1957                       (global-names (map car globals))
1958                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1959                       (globals (append globals initzer-globals))
1960                       (global (make-global-entry name type -1 (append-map (initzer->data info) initzers)))
1961                       (globals (append globals (list global))))
1962                  (clone info #:globals globals)))))
1963
1964         ;; DECL
1965         ;; char *bla[] = {"a", "b"};
1966         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
1967          (let* ((type (decl->ast-type type))
1968                 (entries (filter identity (append-map (initzer->globals globals) initzers)))
1969                 (global-names (map car globals))
1970                 (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
1971                 (globals (append globals entries))
1972                 (entry-size 4)
1973                 (size (* (length entries) entry-size))
1974                 (initzers (map (initzer->non-const info) initzers)))
1975            (if (.function info)
1976                (let* ((count (length initzers))
1977                       (local (car (add-local locals name type -1)))
1978                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (1+ count))))
1979                       (locals (cons local locals))
1980                       (info (clone info #:locals locals))
1981                       (info (clone info #:globals globals))
1982                       (empty (clone info #:text '())))
1983                  (let loop ((index 0) (initzers initzers) (info info))
1984                    (if (null? initzers) info
1985                        (let ((offset (* index 4))
1986                              (initzer (car initzers)))
1987                          (loop (1+ index) (cdr initzers)
1988                                (clone info #:text
1989                                       (append
1990                                        (.text info)
1991                                        ((ident->accu info) name)
1992                                        (wrap-as (append (i386:accu->base)))
1993                                        (.text ((expr->accu empty) initzer))
1994                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1995                (let* ((global (make-global-entry name type -2 (append-map (initzer->data info) initzers)))
1996                       (globals (append globals (list global))))
1997                  (clone info #:globals globals)))))
1998
1999         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
2000          (let* ((info (type->info info type))
2001                 (xtype type)
2002                 (type (decl->ast-type type))
2003                 (name (init-declr->name init))
2004                 (pointer (init-declr->pointer init))
2005                 (initzer-globals (if (null? initzer) '()
2006                                      (filter identity (append-map (initzer->globals globals) initzer))))
2007                 (global-names (map car globals))
2008                 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2009                 (initzer (if (null? initzer) '() ((initzer->non-const info) initzer)))
2010                 (info (append-text info (ast->comment o)))
2011                 (globals (append globals initzer-globals))
2012                 (info (clone info #:globals globals))
2013                 (struct? (and (zero? pointer)
2014                               (or (and (pair? type) (equal? (car type) "tag"))
2015                                   (eq? (type:type (ast-type->type info xtype)) 'struct))))
2016                 (pointer (if struct? -1 pointer))
2017                 (size (if (<= pointer 0) (ast-type->size info type)
2018                           4)))
2019            (if (.function info)
2020                (let* ((locals (if (or (> pointer 0) (<= size 4)) (add-local locals name type pointer)
2021                                   (let* ((local (car (add-local locals name type 1)))
2022                                          (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))))
2023                                     (cons local locals))))
2024                       (info (clone info #:locals locals))
2025                       (info (if (null? initzer) info ((initzer->accu info) (car initzer))))
2026                       (info (if (null? initzer) info (append-text info ((accu->ident info) name)))))
2027                  info)
2028                (let* ((global (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul))
2029                                                                        (append-map (initzer->data info) initzer))))
2030                       (globals (append globals (list global))))
2031                  (clone info #:globals globals)))))
2032
2033         ;; int i = 0, j = 0;
2034         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2035          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2036            (if (null? inits) info
2037                (loop (cdr inits)
2038                      ((decl->info info)
2039                       `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2040
2041         ;; int *i = 0, j ..;
2042         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)) . ,initzer) . ,rest))
2043          (let loop ((inits `((init-declr (ptr-declr ,pointer (ident ,name)) ,@initzer) ,@rest)) (info info))
2044            (if (null? inits) info
2045                (loop (cdr inits)
2046                      ((decl->info info)
2047                       `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2048
2049         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2050          (format (current-error-port) "SKIP: typedef=~s\n" o)
2051          info)        
2052
2053         ((decl (@ ,at))
2054          (format (current-error-port) "SKIP: at=~s\n" o)
2055          info)
2056
2057         ((decl . _) (error "decl->info: unsupported: " o))))))
2058
2059 (define (ast->info info)
2060   (lambda (o)
2061     (let ((functions (.functions info))
2062           (globals (.globals info))
2063           (locals (.locals info))
2064           (constants (.constants info))
2065           (types (.types info))
2066           (text (.text info)))
2067       (pmatch o
2068         (((trans-unit . _) . _)
2069          ((ast-list->info info)  o))
2070         ((trans-unit . ,elements)
2071          ((ast-list->info info) elements))
2072         ((fctn-defn . _) ((function->info info) o))
2073         ((cpp-stmt (define (name ,name) (repl ,value)))
2074          info)
2075
2076         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
2077          info)
2078
2079         ((break)
2080          (let ((label (car (.break info))))
2081            (append-text info (wrap-as (i386:jump label)))))
2082
2083         ((continue)
2084          (let ((label (car (.continue info))))
2085            (append-text info (wrap-as (i386:jump label)))))
2086
2087         ;; FIXME: expr-stmt wrapper?
2088         (trans-unit info)
2089         ((expr-stmt) info)
2090
2091         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
2092         
2093         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
2094          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
2095                                    (append-text info (wrap-as (asm->m1 arg0))))
2096              (let* ((info (append-text info (ast->comment o)))
2097                     (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
2098                (append-text info (wrap-as (i386:accu-zero?))))))
2099
2100         ((if ,test ,then)
2101          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
2102                 (here (number->string (length text)))
2103                 (label (string-append (.function info) "_" here "_"))
2104                 (break-label (string-append label "break"))
2105                 (else-label (string-append label "else"))
2106                 (info ((test-jump-label->info info break-label) test))
2107                 (info ((ast->info info) then))
2108                 (info (append-text info (wrap-as (i386:jump break-label))))
2109                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2110            (clone info
2111                   #:locals locals)))
2112
2113         ((if ,test ,then ,else)
2114          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
2115                 (here (number->string (length text)))
2116                 (label (string-append (.function info) "_" here "_"))
2117                 (break-label (string-append label "break"))
2118                 (else-label (string-append label "else"))
2119                 (info ((test-jump-label->info info else-label) test))
2120                 (info ((ast->info info) then))
2121                 (info (append-text info (wrap-as (i386:jump break-label))))
2122                 (info (append-text info (wrap-as `((#:label ,else-label)))))
2123                 (info ((ast->info info) else))
2124                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2125            (clone info
2126                   #:locals locals)))
2127
2128         ;; Hmm?
2129         ((expr-stmt (cond-expr ,test ,then ,else))
2130          (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
2131                 (here (number->string (length text)))
2132                 (label (string-append (.function info) "_" here "_"))
2133                 (else-label (string-append label "else"))
2134                 (break-label (string-append label "break"))
2135                 (info ((test-jump-label->info info else-label) test))
2136                 (info ((ast->info info) then))
2137                 (info (append-text info (wrap-as (i386:jump break-label))))
2138                 (info (append-text info (wrap-as `((#:label ,else-label)))))
2139                 (info ((ast->info info) else))
2140                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2141            info))
2142
2143         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
2144          (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
2145                 (here (number->string (length text)))
2146                 (label (string-append (.function info) "_" here "_"))
2147                 (break-label (string-append label "break"))
2148                 (clauses (statements->clauses statements))
2149                 (info ((expr->accu info) expr))
2150                 (info (clone info #:break (cons break-label (.break info))))
2151                 (info (let loop ((clauses clauses) (i 0) (info info))
2152                         (if (null? clauses) info
2153                             (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
2154                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2155            (clone info
2156                   #:locals locals
2157                   #:break (cdr (.break info)))))
2158
2159         ((for ,init ,test ,step ,body)
2160          (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
2161                 (here (number->string (length text)))
2162                 (label (string-append (.function info) "_" here "_"))
2163                 (break-label (string-append label "break"))
2164                 (loop-label (string-append label "loop"))
2165                 (continue-label (string-append label "continue"))
2166                 (initial-skip-label (string-append label "initial_skip"))
2167                 (info ((ast->info info) init))
2168                 (info (clone info #:break (cons break-label (.break info))))
2169                 (info (clone info #:continue (cons continue-label (.continue info))))
2170                 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
2171                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2172                 (info ((ast->info info) body))
2173                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2174                 (info ((expr->accu info) step))
2175                 (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
2176                 (info ((test-jump-label->info info break-label) test))
2177                 (info (append-text info (wrap-as (i386:jump loop-label))))
2178                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2179            (clone info
2180                   #:locals locals
2181                   #:break (cdr (.break info))
2182                   #:continue (cdr (.continue info)))))
2183
2184         ((while ,test ,body)
2185          (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
2186                 (here (number->string (length text)))
2187                 (label (string-append (.function info) "_" here "_"))
2188                 (break-label (string-append label "break"))
2189                 (loop-label (string-append label "loop"))
2190                 (continue-label (string-append label "continue"))
2191                 (info (append-text info (wrap-as (i386:jump continue-label))))
2192                 (info (clone info #:break (cons break-label (.break info))))
2193                 (info (clone info #:continue (cons continue-label (.continue info))))
2194                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2195                 (info ((ast->info info) body))
2196                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2197                 (info ((test-jump-label->info info break-label) test))
2198                 (info (append-text info (wrap-as (i386:jump loop-label))))
2199                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2200            (clone info
2201                   #:locals locals
2202                   #:break (cdr (.break info))
2203                   #:continue (cdr (.continue info)))))
2204
2205         ((do-while ,body ,test)
2206          (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
2207                 (here (number->string (length text)))
2208                 (label (string-append (.function info) "_" here "_"))
2209                 (break-label (string-append label "break"))
2210                 (loop-label (string-append label "loop"))
2211                 (continue-label (string-append label "continue"))
2212                 (info (clone info #:break (cons break-label (.break info))))
2213                 (info (clone info #:continue (cons continue-label (.continue info))))
2214                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2215                 (info ((ast->info info) body))
2216                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2217                 (info ((test-jump-label->info info break-label) test))
2218                 (info (append-text info (wrap-as (i386:jump loop-label))))
2219                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2220            (clone info
2221                   #:locals locals
2222                   #:break (cdr (.break info))
2223                   #:continue (cdr (.continue info)))))
2224
2225         ((labeled-stmt (ident ,label) ,statement)
2226          (let ((info (append-text info `(((#:label ,(string-append (.function info) "_label_" label)))))))
2227            ((ast->info info) statement)))
2228
2229         ((goto (ident ,label))
2230          (append-text info (wrap-as (i386:jump (string-append (.function info) "_label_" label)))))
2231
2232         ((return ,expr)
2233          (let ((info ((expr->accu info) expr)))
2234            (append-text info (append (wrap-as (i386:ret))))))
2235
2236         ((decl . ,decl)
2237          ((decl->info info) o))
2238
2239         ;; ...
2240         ((gt . _) ((expr->accu info) o))
2241         ((ge . _) ((expr->accu info) o))
2242         ((ne . _) ((expr->accu info) o))
2243         ((eq . _) ((expr->accu info) o))
2244         ((le . _) ((expr->accu info) o))
2245         ((lt . _) ((expr->accu info) o))
2246         ((lshift . _) ((expr->accu info) o))
2247         ((rshift . _) ((expr->accu info) o))
2248
2249         ;; EXPR
2250         ((expr-stmt ,expression)
2251          (let ((info ((expr->accu info) expression)))
2252            (append-text info (wrap-as (i386:accu-zero?)))))
2253
2254         ;; FIXME: why do we get (post-inc ...) here
2255         ;; (array-ref
2256         (_ (let ((info ((expr->accu info) o)))
2257              (append-text info (wrap-as (i386:accu-zero?)))))))))
2258
2259 (define (enum-def-list->constants constants fields)
2260   (let loop ((fields fields) (i 0) (constants constants))
2261     (if (null? fields) constants
2262         (let* ((field (car fields))
2263                (name (pmatch field
2264                        ((enum-defn (ident ,name) . _) name)))
2265                (i (pmatch field
2266                     ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
2267                     ((enum-defn ,name) i)
2268                     ((enum-defn ,name (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2269                      (+ (cstring->number a) (cstring->number b)))
2270                     ((enum-defn ,name (sub (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2271                      (- (cstring->number a) (cstring->number b)))
2272                     (_ (error "not supported enum field=~s\n" field)))))
2273           (loop (cdr fields)
2274                 (1+ i)
2275                 (append constants (list (ident->constant name i))))))))
2276
2277 (define (initzer->non-const info)
2278   (lambda (o)
2279     (pmatch o
2280       ((initzer (p-expr (ident ,name)))
2281        (let ((value (assoc-ref (.constants info) name)))
2282          `(initzer (p-expr (fixed ,(number->string value))))))
2283       (_ o))))
2284
2285 (define (initzer->value info)
2286   (lambda (o)
2287     (pmatch o
2288       ((p-expr (fixed ,value)) (cstring->number value))
2289       (_ (error "initzer->value: " o)))))
2290
2291 (define (initzer->data info)
2292   (lambda (o)
2293     (pmatch o
2294       ((initzer (p-expr (char ,char)))  (int->bv32 (char->integer (string-ref char 0))))
2295       ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
2296       ((initzer (p-expr (string . ,strings))) `((#:string ,(string-join strings "")) #f #f #f))
2297       ((initzer (initzer-list . ,initzers)) (append-map (initzer->data info) initzers))
2298       ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
2299       ((initzer (ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))))
2300        (let* ((type (decl->ast-type struct))
2301               (offset (field-offset info type field))
2302               (base (cstring->number base)))
2303          (int->bv32 (+ base offset))))
2304       (() (int->bv32 0))
2305       ((initzer ,p-expr)
2306        (int->bv32 (p-expr->number info p-expr)))
2307       (_ (error "initzer->data: unsupported: " o)))))
2308
2309 (define (initzer->accu info)
2310   (lambda (o)
2311     (pmatch o
2312       ((initzer-list . ,initzers) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2313       ((initzer (initzer-list . ,initzers)) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2314       ((initzer ,initzer) ((expr->accu info) o))
2315       (() (append-text info (wrap-as (i386:value->accu 0))))
2316       (_ (error "initzer->accu: " o)))))
2317
2318 (define (expr->global globals)
2319   (lambda (o)
2320     (pmatch o
2321       ((p-expr (string ,string))
2322        (let ((g `(#:string ,string)))
2323          (or (assoc g globals)
2324              (string->global-entry string))))
2325       ((p-expr (string . ,strings))
2326        (let* ((string (string-join strings ""))
2327               (g `(#:string ,string)))
2328          (or (assoc g globals)
2329              (string->global-entry string))))
2330       ;;((p-expr (fixed ,value)) (int->global-entry (cstring->number value)))
2331       (_ #f))))
2332
2333 (define (initzer->globals globals)
2334   (lambda (o)
2335     (pmatch o
2336       ((initzer (initzer-list . ,initzers)) (append-map (initzer->globals globals) initzers))
2337       ((initzer ,initzer) (list ((expr->global globals) initzer)))
2338       (_ '(#f)))))
2339
2340 (define (type->info info o)
2341   (pmatch o
2342     ((struct-def (ident ,name) (field-list . ,fields))
2343      (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
2344        (clone info #:types (cons type-entry (.types info)))))
2345     (_  info)))
2346
2347 (define (.formals o)
2348   (pmatch o
2349     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2350     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2351     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2352     ((fctn-defn _ (ptr-declr (pointer (pointer (pointer))) (ftn-declr _ ,formals)) _) formals)
2353     (_ (error ".formals: " o))))
2354
2355 (define (formal->text n)
2356   (lambda (o i)
2357     ;;(i386:formal i n)
2358     '()
2359     ))
2360
2361 (define (formals->text o)
2362   (pmatch o
2363     ((param-list . ,formals)
2364      (let ((n (length formals)))
2365        (wrap-as (append (i386:function-preamble)
2366                         (append-map (formal->text n) formals (iota n))
2367                         (i386:function-locals)))))
2368     (_ (error "formals->text: unsupported: " o))))
2369
2370 (define (formal:ptr o)
2371   (pmatch o
2372     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2373      0)
2374     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2375      2)
2376     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2377      1)
2378     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2379      1)
2380     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2381      2)
2382     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name))))
2383      3)
2384     (_ 0)))
2385
2386 (define (formals->locals o)
2387   (pmatch o
2388     ((param-list . ,formals)
2389      (let ((n (length formals)))
2390        (map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2391     (_ (error "formals->locals: unsupported: " o))))
2392
2393 (define (function->info info)
2394   (lambda (o)
2395     (define (assert-return text)
2396       (let ((return (wrap-as (i386:ret))))
2397         (if (equal? (list-tail text (- (length text) (length return))) return) text
2398             (append text return))))
2399     (let* ((name (.name o))
2400            (formals (.formals o))
2401            (text (formals->text formals))
2402            (locals (formals->locals formals)))
2403       (format (current-error-port) "    :~a\n" name)
2404       (let loop ((statements (.statements o))
2405                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2406         (if (null? statements) (let* ((locals (.locals info))
2407                                       (local (and (pair? locals) (car locals)))
2408                                       (count (and=> local (compose local:id cdr)))
2409                                       (stack (and count (* count 4))))
2410                                  (if (and stack (getenv "MESC_DEBUG")) (stderr "        stack: ~a\n" stack))
2411                                  (clone info
2412                                        #:function #f
2413                                        #:functions (append (.functions info) (list (cons name (assert-return (.text info)))))))
2414             (let* ((statement (car statements)))
2415               (loop (cdr statements)
2416                     ((ast->info info) (car statements)))))))))
2417
2418 (define (ast-list->info info)
2419   (lambda (elements)
2420     (let loop ((elements elements) (info info))
2421       (if (null? elements) info
2422           (loop (cdr elements) ((ast->info info) (car elements)))))))
2423
2424 (define* (c99-input->info #:key (defines '()) (includes '()))
2425   (lambda ()
2426     (let* ((info (make <info> #:types i386:type-alist))
2427            (foo (stderr "parsing: input\n"))
2428            (ast (c99-input->ast #:defines defines #:includes includes))
2429            (foo (stderr "compiling: input\n"))
2430            (info ((ast->info info) ast))
2431            (info (clone info #:text '() #:locals '())))
2432       info)))
2433
2434 (define* (info->object o)
2435   `((functions . ,(.functions o))
2436     (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2437
2438 (define* (c99-ast->info ast)
2439   ((ast->info (make <info> #:types i386:type-alist)) ast))
2440
2441 (define* (c99-input->elf #:key (defines '()) (includes '()))
2442   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2443
2444 (define* (c99-input->object #:key (defines '()) (includes '()))
2445   ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))