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