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