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