3c9e29861db9a2c7238e932a2f404bd718303dc8
[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     (_ (let ((type (get-type (.types info) o)))
999          (if type (type:size type)
1000              (error "type->size: unsupported: " o))))))
1001
1002 (define (field-offset info struct field)
1003   (let* ((fields (type->description info struct))
1004          (prefix (and=> (member field (reverse fields) (lambda (a b) (equal? a (car b)))) cdr
1005 )))
1006     (apply + (map field:size prefix))))
1007
1008 (define (ast->type o)
1009   (pmatch o
1010     ((fixed-type ,type)
1011      type)
1012     ((struct-ref (ident ,type))
1013      (list "struct" type))
1014     (_ (stderr "SKIP: type=~s\n" o)
1015        "int")))
1016
1017 (define (decl->type o)
1018   (pmatch o
1019     ((fixed-type ,type) type)
1020     ((struct-ref (ident ,name)) (list "struct" name))
1021     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm"
1022      (list "struct" name)) ;; FIXME
1023     ((typename ,name) name)
1024     (,name name)
1025     (_ (error "decl->type: unsupported: " o))))
1026
1027 (define (expr->global globals)
1028   (lambda (o)
1029     (pmatch o
1030       ((p-expr (string ,string))
1031        (let ((g `(#:string ,string)))
1032          (or (assoc g globals)
1033              (string->global string))))
1034       ;;((p-expr (fixed ,value)) (int->global (cstring->number value)))
1035       (_ #f))))
1036
1037 (define (initzer->global globals)
1038   (lambda (o)
1039     (pmatch o
1040       ((initzer ,initzer) ((expr->global globals) initzer))
1041       (_ #f))))
1042
1043 (define (byte->hex.m1 o)
1044   (string-drop o 2))
1045
1046 (define (asm->m1 o)
1047   (let ((prefix ".byte "))
1048     (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
1049         (let ((s (string-drop o (string-length prefix))))
1050           (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
1051
1052 (define (clause->info info i label last?)
1053   (define clause-label
1054     (string-append label "clause" (number->string i)))
1055   (define body-label
1056     (string-append label "body" (number->string i)))
1057   (define (jump label)
1058     (wrap-as (i386:jump label)))
1059   (define (jump-nz label)
1060     (wrap-as (i386:jump-nz label)))
1061   (define (jump-z label)
1062     (wrap-as (i386:jump-z label)))
1063   (define (test->text test)
1064     (let ((value (pmatch test
1065                    (0 0)
1066                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
1067                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1068                    ((p-expr (fixed ,value)) (cstring->number value))
1069                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1070                    (_ (error "case test: unsupported: " test)))))
1071       (append (wrap-as (i386:accu-cmp-value value))
1072               (jump-z body-label))))
1073   (define (cases+jump info cases)
1074     (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
1075            (next-clause-label (if last? (string-append label "break")
1076                                   (string-append label "clause" (number->string (1+ i)))))
1077            (info (append-text info (apply append cases)))
1078            (info (if (null? cases) info
1079                      (append-text info (jump next-clause-label))))
1080            (info (append-text info (wrap-as `((#:label ,body-label))))))
1081       info))
1082
1083   (lambda (o)
1084     (let loop ((o o) (cases '()) (clause #f))
1085       (pmatch o
1086         ((case ,test ,statement)
1087          (loop statement (append cases (list (test->text test))) clause))
1088         ((default ,statement)
1089          (loop statement cases clause))
1090         ((compd-stmt (block-item-list))
1091          (loop '() cases clause))
1092         ((compd-stmt (block-item-list . ,elements))
1093          (let ((clause (or clause (cases+jump info cases))))
1094            (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1095                  ((ast->info clause) (car elements)))))
1096         (()
1097          (let ((clause (or clause (cases+jump info cases))))
1098            (if last? clause
1099                (let ((next-body-label (string-append label "body"
1100                                                      (number->string (1+ i)))))
1101                  (append-text clause (wrap-as (i386:jump next-body-label)))))))
1102         (_
1103          (let ((clause (or clause (cases+jump info cases))))
1104            (loop '() cases
1105                  ((ast->info clause) o))))))))
1106
1107 (define (test-jump-label->info info label)
1108   (define (jump type . test)
1109     (lambda (o)
1110       (let* ((info ((ast->info info) o))
1111              (info (append-text info (make-comment "jmp test LABEL")))
1112              (jump-text (wrap-as (type label))))
1113         (append-text info (append (if (null? test) '() (car test))
1114                                   jump-text)))))
1115   (lambda (o)
1116     (pmatch o
1117       ;; unsigned
1118       ;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
1119       ;; ((lt ,a ,b) ((jump i386:jump-nc) o))  ; jae
1120       ;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
1121       ;; ((gt ,a ,b) ((jump i386:jump-nc) o))
1122
1123       ((le ,a ,b) ((jump i386:jump-g) o))
1124       ((lt ,a ,b) ((jump i386:jump-ge) o))
1125       ((ge ,a ,b) ((jump i386:jump-g) o))
1126       ((gt ,a ,b) ((jump i386:jump-ge) o))
1127
1128       ((ne ,a ,b) ((jump i386:jump-nz) o))
1129       ((eq ,a ,b) ((jump i386:jump-nz) o))
1130       ((not _) ((jump i386:jump-z) o))
1131
1132       ((and ,a ,b)
1133        (let* ((info ((test-jump-label->info info label) a))
1134               (info ((test-jump-label->info info label) b)))
1135          info))
1136
1137       ((or ,a ,b)
1138        (let* ((here (number->string (length (.text info))))
1139               (skip-b-label (string-append label "_skip_b_" here))
1140               (b-label (string-append label "_b_" here))
1141               (info ((test-jump-label->info info b-label) a))
1142               (info (append-text info (wrap-as (i386:jump skip-b-label))))
1143               (info (append-text info (wrap-as `((#:label ,b-label)))))
1144               (info ((test-jump-label->info info label) b))
1145               (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1146          info))
1147
1148       ((array-ref . _) ((jump i386:jump-byte-z
1149                               (wrap-as (i386:accu-zero?))) o))
1150
1151       ((de-ref _) ((jump i386:jump-byte-z
1152                          (wrap-as (i386:accu-zero?))) o))
1153
1154       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1155        ((jump i386:jump-z
1156               (append ((ident->accu info) name)
1157                       (wrap-as (i386:accu-zero?)))) o))
1158
1159       (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
1160
1161 (define (cstring->number s)
1162   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1163         ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1164         ((string-prefix? "0" s) (string->number s 8))
1165         (else (string->number s))))
1166
1167 (define (struct-field o)
1168   (pmatch o
1169     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1170                 (comp-declr-list (comp-declr (ident ,name))))
1171      (list name type 4))
1172     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1173      (list name type 4))
1174     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1175      (list name type 4))
1176     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1177      (list name type 4)) ;; FIXME: **
1178     ((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)))))
1179      (list name type 4)) ;; FIXME function / int
1180     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1181      (list name type 4)) ;; FIXME: ptr/char
1182     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1183      (list name type 4)) ;; FIXME: **
1184     ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1185      (list name '(void) 4)) ;; FIXME: *
1186     ((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)))))
1187      (list name '(void) 4))
1188     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1189      (list name '(void) 4))
1190     ((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)))))))
1191      (let ((size 4)
1192            (count (cstring->number count)))
1193        (list name type (* count size) 0)))
1194     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1195      (let ((size 4)
1196            (count (cstring->number count)))
1197        (list name type (* count size) 0)))
1198     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1199      (let ((size 4)
1200            (count (cstring->number count)))
1201        (list name type (* count size) 0)))
1202     ;; struct InlineFunc **inline_fns;
1203     ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1204      (list name type 4))
1205     ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1206      (list name type 4))
1207     (_ (error "struct-field: unsupported: " o))))
1208
1209 (define (ident->decl info o)
1210   (or (assoc-ref (.locals info) o)
1211       (assoc-ref (.globals info) o)
1212       (begin
1213         (stderr "NO IDENT: ~a\n" o)
1214         (assoc-ref (.functions info) o))))
1215
1216 (define (ident->type info o)
1217   (and=> (ident->decl info o) car))
1218
1219 (define (ident->pointer info o)
1220   (let ((local (assoc-ref (.locals info) o)))
1221     (if local (local:pointer local)
1222         (or (and=> (ident->decl info o) global:pointer) 0))))
1223
1224 (define (p-expr->type info o)
1225   (pmatch o
1226     ((p-expr (ident ,name)) (ident->type info name))
1227     ((array-ref ,index (p-expr (ident ,array)))
1228      (ident->type info array))
1229     (_ (error "p-expr->type: unsupported: " o))))
1230
1231 (define (get-type types o)
1232   (let ((t (assoc-ref types o)))
1233     (pmatch t
1234       ((typedef ,next) (get-type types next))
1235       (_ t))))
1236
1237 (define (type->description info o)
1238   (pmatch o
1239     ((decl-spec-list (type-spec (fixed-type ,type)))
1240      (type->description info type))
1241     ((struct-ref (ident ,type))
1242      (type->description info `("struct" ,type)))
1243     (_ (let ((type (get-type (.types info) o)))
1244          (if (not type) (stderr "TYPES=~s\n" (.types info)))
1245          (if type (type:description type)
1246              (error "type->description: unsupported:" o))))))
1247
1248 (define (local? o) ;; formals < 0, locals > 0
1249   (positive? (local:id o)))
1250
1251 (define (statements->clauses statements)
1252   (let loop ((statements statements) (clauses '()))
1253     (if (null? statements) clauses
1254         (let ((s (car statements)))
1255           (pmatch s
1256             ((case ,test (compd-stmt (block-item-list . _)))
1257              (loop (cdr statements) (append clauses (list s))))
1258             ((case ,test (break))
1259              (loop (cdr statements) (append clauses (list s))))
1260             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1261
1262             ((case ,test ,statement)
1263              (let loop2 ((statement statement) (heads `((case ,test))))
1264                (define (heads->case heads statement)
1265                  (if (null? heads) statement
1266                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1267                (pmatch statement
1268                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1269                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1270                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1271                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1272                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1273                           (let ((s (car statements)))
1274                             (pmatch s
1275                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1276                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1277                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1278                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1279             ((default (compd-stmt (block-item-list _)))
1280              (loop (cdr statements) (append clauses (list s))))
1281             ((default . ,statement)
1282              (let loop2 ((statements (cdr statements)) (c statement))
1283                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1284                    (let ((s (car statements)))
1285                      (pmatch s
1286                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1287                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1288                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1289                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1290
1291                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1292             (_ (error "statements->clauses: unsupported:" s)))))))
1293
1294 (define (ast->info info)
1295   (lambda (o)
1296     (let ((functions (.functions info))
1297           (globals (.globals info))
1298           (locals (.locals info))
1299           (constants (.constants info))
1300           (types (.types info))
1301           (text (.text info)))
1302       (define (add-local locals name type pointer)
1303         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1304                        (1+ (local:id (cdar locals)))))
1305                (locals (cons (make-local name type pointer id) locals)))
1306           locals))
1307       (define (declare name)
1308         (if (member name functions) info
1309             (clone info #:functions (cons (cons name #f) functions))))
1310       (pmatch o
1311         (((trans-unit . _) . _)
1312          ((ast-list->info info)  o))
1313         ((trans-unit . ,elements)
1314          ((ast-list->info info) elements))
1315         ((fctn-defn . _) ((function->info info) o))
1316         ((cpp-stmt (define (name ,name) (repl ,value)))
1317          info)
1318
1319         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1320          info)
1321
1322         ((break)
1323          (let ((label (car (.break info))))
1324            (append-text info (wrap-as (i386:jump label)))))
1325
1326         ((continue)
1327          (let ((label (car (.continue info))))
1328            (append-text info (wrap-as (i386:jump label)))))
1329
1330         ;; FIXME: expr-stmt wrapper?
1331         (trans-unit info)
1332         ((expr-stmt) info)
1333
1334         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1335         
1336         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1337          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1338                                    (append-text info (wrap-as (asm->m1 arg0))))
1339              (let* ((info (append-text info (ast->comment o)))
1340                     (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1341                (append-text info (wrap-as (i386:accu-zero?))))))
1342
1343         ((if ,test ,then)
1344          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
1345                 (here (number->string (length text)))
1346                 (label (string-append (.function info) "_" here "_"))
1347                 (break-label (string-append label "break"))
1348                 (else-label (string-append label "else"))
1349                 (info ((test-jump-label->info info break-label) test))
1350                 (info ((ast->info info) then))
1351                 (info (append-text info (wrap-as (i386:jump break-label))))
1352                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1353            (clone info
1354                   #:locals locals)))
1355
1356         ((if ,test ,then ,else)
1357          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
1358                 (here (number->string (length text)))
1359                 (label (string-append (.function info) "_" here "_"))
1360                 (break-label (string-append label "break"))
1361                 (else-label (string-append label "else"))
1362                 (info ((test-jump-label->info info else-label) test))
1363                 (info ((ast->info info) then))
1364                 (info (append-text info (wrap-as (i386:jump break-label))))
1365                 (info (append-text info (wrap-as `((#:label ,else-label)))))
1366                 (info ((ast->info info) else))
1367                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1368            (clone info
1369                   #:locals locals)))
1370
1371         ;; Hmm?
1372         ((expr-stmt (cond-expr ,test ,then ,else))
1373          (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
1374                 (here (number->string (length text)))
1375                 (label (string-append (.function info) "_" here "_"))
1376                 (else-label (string-append label "else"))
1377                 (break-label (string-append label "break"))
1378                 (info ((test-jump-label->info info else-label) test))
1379                 (info ((ast->info info) then))
1380                 (info (append-text info (wrap-as (i386:jump break-label))))
1381                 (info (append-text info (wrap-as `((#:label ,else-label)))))
1382                 (info ((ast->info info) else))
1383                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1384            info))
1385
1386         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1387          (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
1388                 (here (number->string (length text)))
1389                 (label (string-append (.function info) "_" here "_"))
1390                 (break-label (string-append label "break"))
1391                 (clauses (statements->clauses statements))
1392                 (info ((expr->accu info) expr))
1393                 (info (clone info #:break (cons break-label (.break info))))
1394                 (info (let loop ((clauses clauses) (i 0) (info info))
1395                         (if (null? clauses) info
1396                             (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
1397                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1398            (clone info
1399                   #:locals locals
1400                   #:break (cdr (.break info)))))
1401
1402         ((for ,init ,test ,step ,body)
1403          (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
1404                 (here (number->string (length text)))
1405                 (label (string-append (.function info) "_" here "_"))
1406                 (break-label (string-append label "break"))
1407                 (loop-label (string-append label "loop"))
1408                 (continue-label (string-append label "continue"))
1409                 (initial-skip-label (string-append label "initial_skip"))
1410                 (info ((ast->info info) init))
1411                 (info (clone info #:break (cons break-label (.break info))))
1412                 (info (clone info #:continue (cons continue-label (.continue info))))
1413                 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
1414                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
1415                 (info ((ast->info info) body))
1416                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
1417                 (info ((expr->accu info) step))
1418                 (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
1419                 (info ((test-jump-label->info info break-label) test))
1420                 (info (append-text info (wrap-as (i386:jump loop-label))))
1421                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1422            (clone info
1423                   #:locals locals
1424                   #:break (cdr (.break info))
1425                   #:continue (cdr (.continue info)))))
1426
1427         ((while ,test ,body)
1428          (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
1429                 (here (number->string (length text)))
1430                 (label (string-append (.function info) "_" here "_"))
1431                 (break-label (string-append label "break"))
1432                 (loop-label (string-append label "loop"))
1433                 (continue-label (string-append label "continue"))
1434                 (info (append-text info (wrap-as (i386:jump continue-label))))
1435                 (info (clone info #:break (cons break-label (.break info))))
1436                 (info (clone info #:continue (cons continue-label (.continue info))))
1437                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
1438                 (info ((ast->info info) body))
1439                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
1440                 (info ((test-jump-label->info info break-label) test))
1441                 (info (append-text info (wrap-as (i386:jump loop-label))))
1442                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1443            (clone info
1444                   #:locals locals
1445                   #:break (cdr (.break info))
1446                   #:continue (cdr (.continue info)))))
1447
1448         ((do-while ,body ,test)
1449          (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
1450                 (here (number->string (length text)))
1451                 (label (string-append (.function info) "_" here "_"))
1452                 (break-label (string-append label "break"))
1453                 (loop-label (string-append label "loop"))
1454                 (continue-label (string-append label "continue"))
1455                 (info (clone info #:break (cons break-label (.break info))))
1456                 (info (clone info #:continue (cons continue-label (.continue info))))
1457                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
1458                 (info ((ast->info info) body))
1459                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
1460                 (info ((test-jump-label->info info break-label) test))
1461                 (info (append-text info (wrap-as (i386:jump loop-label))))
1462                 (info (append-text info (wrap-as `((#:label ,break-label))))))
1463            (clone info
1464                   #:locals locals
1465                   #:break (cdr (.break info))
1466                   #:continue (cdr (.continue info)))))
1467
1468         ((labeled-stmt (ident ,label) ,statement)
1469          (let ((info (append-text info `(((#:label ,(string-append (.function info) "_label_" label)))))))
1470            ((ast->info info) statement)))
1471
1472         ((goto (ident ,label))
1473          (append-text info (wrap-as (i386:jump (string-append (.function info) "_label_" label)))))
1474
1475         ((return ,expr)
1476          (let ((info ((expr->accu info) expr)))
1477            (append-text info (append (wrap-as (i386:ret))))))
1478
1479         ;; DECL
1480
1481         ;; int i;
1482         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1483          (if (.function info)
1484              (clone info #:locals (add-local locals name type 0))
1485              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1486
1487         ;; enum e i;
1488         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1489          (let ((type "int")) ;; FIXME
1490            (if (.function info)
1491                (clone info #:locals (add-local locals name type 0))
1492                (clone info #:globals (append globals (list (ident->global name type 0 0)))))))
1493
1494         ;; int i = 0;
1495         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1496          (let ((value (cstring->number value)))
1497            (if (.function info)
1498                (let* ((locals (add-local locals name type 0))
1499                       (info (clone info #:locals locals)))
1500                  (append-text info ((value->ident info) name value)))
1501                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1502
1503         ;; char c = 'A';
1504         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1505          (if (not (.function info)) (error "ast->info: unsupported: " o))
1506          (let* ((locals (add-local locals name type 0))
1507                 (info (clone info #:locals locals))
1508                 (value (char->integer (car (string->list value)))))
1509            (append-text info ((value->ident info) name value))))
1510
1511         ;; int i = -1;
1512         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1513          (let ((value (- (cstring->number value))))
1514            (if (.function info)
1515                (let* ((locals (add-local locals name type 0))
1516                       (info (clone info #:locals locals)))
1517                  (append-text info ((value->ident info) name value)))
1518                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1519
1520         ;; int i = argc;
1521         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1522          (if (not (.function info)) (error "ast->info: unsupported: " o))
1523          (let* ((locals (add-local locals name type 0))
1524                 (info (clone info #:locals locals)))
1525            (append-text info (append ((ident->accu info) local)
1526                                      ((accu->ident info) name)))))
1527
1528         ;; char *p = "foo";
1529         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1530          (if (.function info)
1531              (let* ((locals (add-local locals name type 1))
1532                     (globals ((globals:add-string globals) string))
1533                     (info (clone info #:locals locals #:globals globals)))
1534                (append-text info (append
1535                                   (list (i386:label->accu `(#:string ,string)))
1536                                   ((accu->ident info) name))))
1537              (let* ((globals ((globals:add-string globals) string))
1538                     (size 4)
1539                     (global (make-global name type 1 (initzer->data `(initzer (p-expr (string ,string))))))
1540                     (globals (append globals (list global))))
1541                (clone info #:globals globals))))
1542         
1543         ;; char *p;
1544         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1545          (if (.function info)
1546              (let* ((locals (add-local locals name type 1))
1547                     (info (clone info #:locals locals)))
1548                (append-text info (append (wrap-as (i386:value->accu 0))
1549                                          ((accu->ident info) name))))
1550              (let ((globals (append globals (list (ident->global name type 1 0)))))
1551                (clone info #:globals globals))))
1552
1553         ;; char *p = 0;
1554         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1555          (let ((value (cstring->number value)))
1556            (if (.function info)
1557                (let* ((locals (add-local locals name type 1))
1558                       (info (clone info #:locals locals)))
1559                  (append-text info (append (wrap-as (i386:value->accu value))
1560                                            ((accu->ident info) name))))
1561                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1562
1563         ;; FILE *p;
1564         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1565          (if (.function info)
1566              (let* ((locals (add-local locals name type 1))
1567                     (info (clone info #:locals locals)))
1568                (append-text info (append (wrap-as (i386:value->accu 0))
1569                                          ((accu->ident info) name))))
1570              (let ((globals (append globals (list (ident->global name type 1 0)))))
1571                (clone info #:globals globals))))
1572
1573         ;; FILE *p = 0;
1574         ((decl (decl-spec-list (type-spec (typename ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1575          (let ((value (cstring->number value)))
1576            (if (.function info)
1577                (let* ((locals (add-local locals name type 1))
1578                       (info (clone info #:locals locals)))
1579                  (append-text info (append (wrap-as (i386:value->accu value))
1580                                            ((accu->ident info) name))))
1581                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1582
1583         ;; char **p;
1584         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1585          (if (.function info)
1586              (let* ((locals (add-local locals name type 2))
1587                     (info (clone info #:locals locals)))
1588                (append-text info (append (wrap-as (i386:value->accu 0))
1589                                          ((accu->ident info) name))))
1590              (let ((globals (append globals (list (ident->global name type 2 0)))))
1591                (clone info #:globals globals))))
1592
1593         ;; char **p = g_environment;
1594         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
1595          (if (.function info)
1596              (let* ((locals (add-local locals name type 2))
1597                     (info (clone info #:locals locals)))
1598                (append-text info (append
1599                                   ((ident->accu info) b)
1600                                   ((accu->ident info) name))))
1601              (let* ((value (assoc-ref constants b))
1602                     (global (ident->global name type 2 (initzer->data `(p-expr (fixed ,value)))))
1603                     (globals (append globals (list global))))
1604                (clone info #:globals globals))))
1605
1606         ;; struct foo bar[2];
1607         ;; char arena[20000];
1608         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1609          (let ((type (ast->type type)))
1610            (if (.function info)
1611                (let* ((local (car (add-local locals name type -1)))
1612                       (count (string->number count))
1613                       (size (type->size info type))
1614                       (local (make-local name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))                      
1615                       (locals (cons local locals))
1616                       (info (clone info #:locals locals)))
1617                  info)
1618                (let* ((globals (.globals info))
1619                       (count (cstring->number count))
1620                       (size (type->size info type))
1621                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1622                       (globals (append globals (list array))))
1623                  (clone info #:globals globals)))))
1624
1625         ;; char* a[10];
1626         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1627          (let ((type (ast->type type)))
1628            (if (.function info)
1629                (let* ((local (car (add-local locals name type -1)))
1630                       (count (string->number count))
1631                       (size (type->size info type))
1632                       (local (make-local name type 1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))
1633                       (locals (cons local locals))
1634                       (info (clone info #:locals locals)))
1635                  info)
1636                (let* ((globals (.globals info))
1637                       (count (cstring->number count))
1638                       (size (type->size info type))
1639                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1640                       (globals (append globals (list array))))
1641                  (clone info #:globals globals)))))
1642
1643         ;; struct foo bar;
1644         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1645          (if (.function info)
1646              (let* ((size (type->size info (list "struct" type)))
1647                     (local (car (add-local locals name type 1)))
1648                     (local (make-local name `("struct" ,type) -1 (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
1649                     (locals (cons local locals)))
1650                (clone info #:locals locals))
1651              (let* ((size (type->size info (list "struct" type)))
1652                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1653                     (globals (append globals (list global)))
1654                     (info (clone info #:globals globals)))
1655                info)))
1656
1657         ;;struct scm *g_cells = (struct scm*)arena;
1658         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
1659          (if (.function info)
1660              (let* ((locals (add-local locals name `("struct" ,type) 1))
1661                     (info (clone info #:locals locals)))
1662                (append-text info (append ((ident->accu info) name)
1663                                          ((accu->ident info) value)))) ;; FIXME: deref?
1664              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1665                     (info (clone info #:globals globals)))
1666                (append-text info (append ((ident->accu info) name)
1667                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1668
1669         ;; SCM tmp;
1670         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1671          (if (.function info)
1672              (let ((size (type->size info type)))
1673                (if (<= size 4) (clone info #:locals (add-local locals name type 0))
1674                    (let* ((local (car (add-local locals name type 1)))
1675                           (local (make-local name type -1 (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
1676                           (locals (cons local locals)))
1677                      (clone info #:locals locals))))
1678              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1679
1680         ;; SCM g_stack = 0;
1681         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1682          (let ((value (cstring->number value)))
1683            (if (.function info)
1684                (let* ((locals (add-local locals name type 0))
1685                       (info (clone info #:locals locals)))
1686                  (append-text info ((value->ident info) name value)))
1687                (let ((globals (append globals (list (ident->global name type 0 value)))))
1688                  (clone info #:globals globals)))))
1689
1690         ;; SCM i = argc;
1691         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1692          (if (.function info)
1693              (let* ((locals (add-local locals name type 0))
1694                     (info (clone info #:locals locals)))
1695                (append-text info (append ((ident->accu info) local)
1696                                          ((accu->ident info) name))))
1697              (let* ((globals (append globals (list (ident->global name type 0 0))))
1698                     (info (clone info #:globals globals)))
1699                (append-text info (append ((ident->accu info) local)
1700                                          ((accu->ident info) name))))))
1701
1702         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1703         ((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))))
1704          (let* ((locals (add-local locals name type 1))
1705                 (info (clone info #:locals locals))
1706                 (empty (clone info #:text '()))
1707                 (accu ((expr->accu empty) initzer)))
1708            (clone info
1709                   #:text
1710                   (append text
1711                           (.text accu)
1712                           ((accu->ident info) name)
1713                           (wrap-as (append (i386:label->base `(#:address "_start"))
1714                                            (i386:accu+base))))
1715                   #:locals locals)))
1716
1717         ;; char *p = (char*)g_cells;
1718         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
1719          (if (.function info)
1720              (let* ((locals (add-local locals name type 1))
1721                     (info (clone info #:locals locals)))
1722                (append-text info (append ((ident->accu info) value)
1723                                          ((accu->ident info) name))))
1724              (let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
1725                (clone info #:globals globals))))
1726
1727         ;; char *p = g_cells;
1728         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1729          (let ((type (decl->type type)))
1730            (if (.function info)
1731                (let* ((locals (add-local locals name type  1))
1732                       (info (clone info #:locals locals)))
1733                  (append-text info (append ((ident->accu info) value)
1734                                            ((accu->ident info) name))))
1735                (let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
1736                  (clone info #:globals globals)))))
1737
1738         ;; enum foo { };
1739         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1740          (let ((type (enum->type name fields))
1741                (constants (enum-def-list->constants constants fields)))
1742            (clone info
1743                   #:types (append types (list type))
1744                   #:constants (append constants (.constants info)))))
1745
1746         ;; enum {};
1747         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1748          (let ((constants (enum-def-list->constants constants fields)))
1749            (clone info
1750                   #:constants (append constants (.constants info)))))
1751
1752         ;; FIXME TCC/Nyacc madness here: extra parentheses around struct name?!?
1753         ;; struct (FOO) WTF?
1754         ((decl (decl-spec-list (type-spec (struct-def (ident (,name)) (field-list . ,fields)))))
1755          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1756            (clone info #:types (append types (list type)))))
1757
1758         ((decl (decl-spec-list (type-spec (struct-def (ident (,type)) (field-list . ,fields))))
1759                (init-declr-list (init-declr (ident ,name))))
1760          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1761            ((ast->info info)
1762             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1763
1764         ;; struct foo* bar = expr;
1765          ((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)))))))
1766          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1767                                      (info (clone info #:locals locals)))
1768                  (append-text info (append ((ident-address->accu info) value)
1769                                            ((accu->ident info) name))))
1770              (error "ast->info: unsupported global:" o)))
1771          ;; END FIXME -- dupe of the below
1772
1773
1774         ;; struct
1775         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1776          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1777            (clone info #:types (cons type types))))
1778
1779         ;; struct foo {} bar;
1780         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1781                (init-declr-list (init-declr (ident ,name))))
1782          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1783            ((ast->info info)
1784             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1785
1786         ;; struct foo* bar = expr;
1787          ((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)))))))
1788          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1789                                      (info (clone info #:locals locals)))
1790                  (append-text info (append ((ident-address->accu info) value)
1791                                            ((accu->ident info) name))))
1792              (error "ast->info: unsupported global:" o)))
1793
1794         ;; char *p = &bla;
1795         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1796          (let ((type (decl->type type)))
1797            (if (.function info)
1798                (let* ((locals (add-local locals name type 1))
1799                       (info (clone info #:locals locals)))
1800                  (append-text info (append ((ident-address->accu info) value)
1801                                            ((accu->ident info) name))))
1802                (error "TODO" o))))
1803
1804         ;; char **p = &bla;
1805         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1806          (let ((type (decl->type type)))
1807            (if (.function info)
1808                (let* ((locals (add-local locals name type 2))
1809                       (info (clone info #:locals locals)))
1810                  (append-text info (append ((ident-address->accu info) value)
1811                                            ((accu->ident info) name))))
1812                (error "TODO" o))))
1813
1814         ;; char *p = bla[0];
1815         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (array-ref ,index (p-expr (ident ,array)))))))
1816          (if (.function info)
1817              (let* ((locals (add-local locals name type 1))
1818                     (info (clone info #:locals locals))
1819                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1820                (append-text info ((accu->ident info) name)))
1821              (error "TODO" o)))
1822
1823         ;; char *foo = &bar[0];
1824         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (array-ref ,index (p-expr (ident ,array))))))))
1825          (if (.function info)
1826              (let* ((locals (add-local locals name type 1))
1827                     (info (clone info #:locals locals))
1828                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1829                (append-text info ((accu->ident info) name)))
1830              (error "TODO" o)))
1831
1832         ;; char *p = *bla;
1833         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (de-ref (p-expr (ident ,value)))))))
1834          (if (.function info)
1835              (let* ((locals (add-local locals name type 1))
1836                     (info (clone info #:locals locals))
1837                     (local (assoc-ref (.locals info) name)))
1838                (append-text info (append ((ident->accu info) value)
1839                                          (wrap-as (i386:mem->accu))
1840                                          ((accu->ident info) name))))
1841              (error "TODO" o)))
1842
1843         ;; DECL
1844         ;; char *bla[] = {"a", "b"};
1845         ((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)))))
1846          (let* ((type (decl->type type))
1847                 (entries (map (initzer->global globals) initzers))
1848                 (entry-size 4)
1849                 (size (* (length entries) entry-size))
1850                 (initzers (map (initzer->non-const info) initzers)))
1851            (if (.function info)
1852                (error "TODO: <type> x[] = {};" o)
1853                (let* (;;(global (make-global name type 2 (string->list (make-string size #\nul))))
1854                       (global (make-global name type 2 (append-map initzer->data initzers)))
1855                       (global-names (map car globals))
1856                       (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
1857                       (globals (append globals entries (list global))))
1858                  (clone info #:globals globals)))))
1859
1860         ;;
1861         ;; struct f = {...};
1862         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1863          (let* ((info (append-text info (ast->comment o)))
1864                 (type (decl->type type))
1865                 (fields (type->description info type))
1866                 (size (type->size info type))
1867                 (initzers (map (initzer->non-const info) initzers)))
1868            (if (.function info)
1869                (let* ((initzer-globals (filter-map (initzer->global globals) initzers))
1870                       (global-names (map car globals))
1871                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1872                       (globals (append globals initzer-globals))
1873                       (locals (let loop ((fields (cdr fields)) (locals locals))
1874                                 (if (null? fields) locals
1875                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1876                       (locals (add-local locals name type -1))
1877                       (info (clone info #:locals locals #:globals globals))
1878                       (empty (clone info #:text '())))
1879                  (let loop ((fields fields) (initzers initzers) (info info))
1880                    (if (null? fields) info
1881                        (let ((offset (field-offset info type (caar fields)))
1882                              (initzer (car initzers)))
1883                          (loop (cdr fields) (cdr initzers)
1884                                (clone info #:text
1885                                       (append
1886                                        (.text info)
1887                                        ((ident->accu info) name)
1888                                        (wrap-as (append (i386:accu->base)))
1889                                        (.text ((expr->accu empty) initzer))
1890                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1891                (let* ((initzer-globals (filter-map (initzer->global globals) initzers))
1892                       (global-names (map car globals))
1893                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1894                       (globals (append globals initzer-globals))
1895                       (global (make-global name type 2 (append-map initzer->data initzers)))
1896                       (globals (append globals (list global))))
1897                  (clone info #:globals globals)))))
1898
1899         ;;char cc = g_cells[c].cdr;  ==> generic?
1900         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1901          (let ((type (decl->type type))
1902                (initzer ((initzer->non-const info) initzer))
1903                (info (append-text info (ast->comment o))))
1904            (if (.function info)
1905                (let* ((locals (add-local locals name type 0))
1906                       (info (clone info #:locals locals))
1907                       (info ((expr->accu info) initzer)))
1908                  (append-text info ((accu->ident info) name)))
1909                (let* ((global (make-global name type 2 (initzer->data initzer)))
1910                       (globals (append globals (list global))))
1911                  (clone info #:globals globals)))))
1912
1913         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1914          (declare name))
1915
1916         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1917          (clone info #:types (cons (cons name (get-type types type)) types)))
1918
1919         ;; int foo ();
1920         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1921          (declare name))
1922
1923         ;; void foo ();
1924         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1925          (declare name))
1926
1927         ;; void foo (*);
1928         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1929          (declare name))
1930
1931         ;; char *strcpy ();
1932         ((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))))))
1933          (declare name))
1934
1935         ;; printf (char const* format, ...)
1936         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1937          (declare name))
1938
1939         ;; <name> tcc_new
1940         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1941          (declare name))
1942
1943         ;; extern type foo ()
1944         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1945          (declare name))
1946
1947         ;; struct TCCState;
1948         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
1949          info)
1950
1951         ;; extern type global;
1952         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
1953          info)
1954
1955         ;; ST_DATA struct TCCState *tcc_state;
1956         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1957          info)
1958
1959         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
1960         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1961          info)
1962
1963         ;; ST_DATA const int *macro_ptr;
1964         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1965          info)
1966
1967         ;; ST_DATA TokenSym **table_ident;
1968         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1969          info)
1970
1971         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
1972         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
1973          info)
1974
1975         ;; ST_DATA void **sym_pools;
1976         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1977          info)
1978
1979         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
1980         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1981          info)
1982
1983         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
1984         ;; Yay, let's hear it for the T-for Tiny in TCC!?
1985         ((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)))))
1986          info)
1987
1988         ;; ST_DATA char *funcname;
1989         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1990          info)
1991
1992         ;; int i = 0, j = 0;
1993         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
1994          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
1995            (if (null? inits) info
1996                (loop (cdr inits)
1997                      ((ast->info info)
1998                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
1999
2000         ;; char *foo[0], *bar;
2001         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,index)) . ,rest))
2002          (let loop ((inits `((init-declr (array-of (ident ,name) ,index)) ,@rest)) (info info))
2003            (if (null? inits) info
2004                (loop (cdr inits)
2005                      ((ast->info info)
2006                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2007
2008
2009         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name))))
2010          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2011
2012         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2013          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2014
2015         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2016          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2017
2018         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
2019          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
2020
2021         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
2022          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name)))))))
2023            (clone info #:types (cons (cons name (or (get-type types `("struct" ,name)) `(typedef ,name))) types))))
2024
2025         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2026          (let* ((type (get-type types type))
2027                 (type (make-type name
2028                                  (type:type type)
2029                                  (type:size type)
2030                                  (1+ (type:pointer type))
2031                                  (type:description type))))
2032            (clone info #:types (cons type types))))
2033
2034         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2035          (format (current-error-port) "SKIP: typedef=~s\n" o)
2036          info)        
2037
2038         ((decl (@ ,at))
2039          (format (current-error-port) "SKIP: at=~s\n" o)
2040          info)
2041
2042         ((decl . _) (error "ast->info: unsupported: " o))
2043
2044         ;; ...
2045         ((gt . _) ((expr->accu info) o))
2046         ((ge . _) ((expr->accu info) o))
2047         ((ne . _) ((expr->accu info) o))
2048         ((eq . _) ((expr->accu info) o))
2049         ((le . _) ((expr->accu info) o))
2050         ((lt . _) ((expr->accu info) o))
2051         ((lshift . _) ((expr->accu info) o))
2052         ((rshift . _) ((expr->accu info) o))
2053
2054         ;; EXPR
2055         ((expr-stmt ,expression)
2056          (let ((info ((expr->accu info) expression)))
2057            (append-text info (wrap-as (i386:accu-zero?)))))
2058
2059         ;; FIXME: why do we get (post-inc ...) here
2060         ;; (array-ref
2061         (_ (let ((info ((expr->accu info) o)))
2062              (append-text info (wrap-as (i386:accu-zero?)))))))))
2063
2064 (define (enum-def-list->constants constants fields)
2065   (let loop ((fields fields) (i 0) (constants constants))
2066     (if (null? fields) constants
2067         (let* ((field (car fields))
2068                (name (pmatch field
2069                        ((enum-defn (ident ,name) . _) name)))
2070                (i (pmatch field
2071                     ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
2072                     ((enum-defn ,name) i)
2073                     ((enum-defn ,name (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2074                      (+ (cstring->number a) (cstring->number b)))
2075                     ((enum-defn ,name (sub (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2076                      (- (cstring->number a) (cstring->number b)))
2077                     (_ (error "not supported enum field=~s\n" field)))))
2078           (loop (cdr fields)
2079                 (1+ i)
2080                 (append constants (list (ident->constant name i))))))))
2081
2082 (define (initzer->non-const info)
2083   (lambda (o)
2084     (pmatch o
2085       ((initzer (p-expr (ident ,name)))
2086        (let ((value (assoc-ref (.constants info) name)))
2087          `(initzer (p-expr (fixed ,(number->string value))))))
2088       (_ o))))
2089
2090 (define (initzer->data o)
2091   (pmatch o
2092     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2093     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2094     ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
2095     ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
2096     (_ (error "initzer->data: unsupported: " o))))
2097
2098 (define (.formals o)
2099   (pmatch o
2100     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2101     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2102     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2103     (_ (error ".formals: " o))))
2104
2105 (define (formal->text n)
2106   (lambda (o i)
2107     ;;(i386:formal i n)
2108     '()
2109     ))
2110
2111 (define (formals->text o)
2112   (pmatch o
2113     ((param-list . ,formals)
2114      (let ((n (length formals)))
2115        (wrap-as (append (i386:function-preamble)
2116                         (append-map (formal->text n) formals (iota n))
2117                         (i386:function-locals)))))
2118     (_ (error "formals->text: unsupported: " o))))
2119
2120 (define (formal:ptr o)
2121   (pmatch o
2122     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2123      0)
2124     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2125      2)
2126     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2127      1)
2128     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2129      1)
2130     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2131      2)
2132     (_
2133      (stderr "formal:ptr[~a] => ~a\n" o 0)
2134      0)))
2135
2136 (define (formals->locals o)
2137   (pmatch o
2138     ((param-list . ,formals)
2139      (let ((n (length formals)))
2140        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2141     (_ (error "formals->locals: unsupported: " o))))
2142
2143 (define (function->info info)
2144   (lambda (o)
2145     (define (assert-return text)
2146       (let ((return (wrap-as (i386:ret))))
2147         (if (equal? (list-tail text (- (length text) (length return))) return) text
2148             (append text return))))
2149     (let* ((name (.name o))
2150            (formals (.formals o))
2151            (text (formals->text formals))
2152            (locals (formals->locals formals)))
2153       (format (current-error-port) "    :~a\n" name)
2154       (let loop ((statements (.statements o))
2155                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2156         (if (null? statements) (clone info
2157                                       #:function #f
2158                                       #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2159             (let* ((statement (car statements)))
2160               (loop (cdr statements)
2161                     ((ast->info info) (car statements)))))))))
2162
2163 (define (ast-list->info info)
2164   (lambda (elements)
2165     (let loop ((elements elements) (info info))
2166       (if (null? elements) info
2167           (loop (cdr elements) ((ast->info info) (car elements)))))))
2168
2169 (define* (c99-input->info #:key (defines '()) (includes '()))
2170   (lambda ()
2171     (let* ((info (make <info> #:types i386:type-alist))
2172            (foo (stderr "parsing: input\n"))
2173            (ast (c99-input->ast #:defines defines #:includes includes))
2174            (foo (stderr "compiling: input\n"))
2175            (info ((ast->info info) ast))
2176            (info (clone info #:text '() #:locals '())))
2177       info)))
2178
2179 (define* (info->object o)
2180   `((functions . ,(.functions o))
2181     (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2182
2183 (define* (c99-ast->info ast)
2184   ((ast->info (make <info> #:types i386:type-alist)) ast))
2185
2186 (define* (c99-input->elf #:key (defines '()) (includes '()))
2187   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2188
2189 (define* (c99-input->object #:key (defines '()) (includes '()))
2190   ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))