build: Update Guix build and install.
[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 (mes pmatch))
34   (mes-use-module (nyacc lang c99 parser))
35   (mes-use-module (mes elf-util))
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 (mescc)
50   (parse-c99
51    #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
52    #:cpp-defs `(
53                 "_POSIX_SOURCE=0"
54                 "__GNUC__=0"
55                 "__MESC__=1"
56                 "__NYACC__=1" ;; REMOVEME
57                 "STDIN=0"
58                 "STDOUT=1"
59                 "STDERR=2"
60                 "O_RDONLY=0"
61
62                 "INT_MIN=-2147483648"
63                 "INT_MAX=2147483647"
64
65                 ,(string-append "DATADIR=\"" %datadir "\"")
66                 ,(string-append "DOCDIR=\"" %docdir "\"")
67                 ,(string-append "PREFIX=\"" %prefix "\"")
68                 ,(string-append "MODULEDIR=\"" %moduledir "\"")
69                 ,(string-append "VERSION=\"" %version "\"")
70                 )
71    #:mode 'code))
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         ;; g_cells[0]
558         ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
559          (let* ((index (cstring->number index))
560                 (type (ident->type info array))
561                 (size (type->size info type)))
562            (clone info #:text
563                   (append text
564                         ((ident->base info) array)
565                         (list (lambda (f g ta t d)
566                                 (append
567                                  (i386:value->accu (* size index))
568                                  (case size
569                                    ((1) (i386:byte-base-mem->accu))
570                                    ((4) (i386:base-mem->accu))
571                                    (else (i386:accu+base))))))))))
572
573         ;; c+p expr->arg
574         ;; g_cells[i]
575         ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
576          (let* ((type (ident->type info array))
577                 (size (type->size info type)))
578            (clone info #:text (append text
579                                       ((ident->base info) index)
580                                       (list (lambda (f g ta t d)
581                                               (append
582                                                (i386:base->accu)
583                                                (if (< size 4) '()
584                                                    (append
585                                                     (i386:accu+accu)
586                                                     (if (= size 12) (i386:accu+base) '())
587                                                     (i386:accu-shl 2))))))
588                                       ((ident->base info) array)
589                                       (list (lambda (f g ta t d)
590                                               (case size
591                                                 ((1) (i386:byte-base-mem->accu))
592                                                 ((4) (i386:base-mem->accu))
593                                                 (else (i386:accu+base)))))))))
594
595         ;; f.field
596         ((d-sel (ident ,field) (p-expr (ident ,array)))
597          (let* ((type (ident->type info array))
598                 (fields (type->description info type))
599                 (field-size 4) ;; FIXME:4, not fixed
600                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
601                 (text (.text info)))
602            (clone info #:text
603                   (append text
604                           ((ident->accu info) array)
605                           (list (lambda (f g ta t d)
606                                   (i386:mem+n->accu offset)))))))
607
608         ;; g_cells[10].type
609         ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
610          (let* ((type (ident->type info array))
611                 (fields (or (type->description info type) '()))
612                 (size (type->size info type))
613                 (count (length fields))
614                 (field-size 4) ;; FIXME:4, not fixed
615                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
616                 (index (cstring->number index))
617                 (text (.text info)))
618            (clone info #:text
619                   (append text
620                           (list (lambda (f g ta t d)
621                                   (append
622                                    (i386:value->base index)
623                                    (i386:base->accu)
624                                    (if (> count 1) (i386:accu+accu) '())
625                                    (if (= count 3) (i386:accu+base) '())
626                                    (i386:accu-shl 2))))
627                           ((ident->base info) array)
628                           (list (lambda (f g ta t d)
629                                   (i386:base-mem+n->accu offset)))))))
630         
631         ;; g_cells[x].type
632         ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
633          (let* ((type (ident->type info array))
634                 (fields (or (type->description info type) '()))
635                 (size (type->size info type))
636                 (count (length fields))
637                 (field-size 4) ;; FIXME:4, not fixed
638                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
639                       (text (.text info)))
640                  (clone info #:text
641                         (append text
642                                 ((ident->base info) index)
643                                 (list (lambda (f g ta t d)
644                                         (append
645                                          (i386:base->accu)
646                                          (if (> count 1) (i386:accu+accu) '())
647                                          (if (= count 3) (i386:accu+base) '())
648                                          (i386:accu-shl 2))))
649                                 ((ident->base info) array)
650                                 (list (lambda (f g ta t d)
651                                         (i386:base-mem+n->accu offset)))))))
652
653         ;; g_functions[g_cells[fn].cdr].arity
654         ;; INDEX0: g_cells[fn].cdr
655
656         ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
657         ;;((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)))))
658         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
659          (let* ((empty (clone info #:text '()))
660                 (index ((expr->accu empty) index))
661                 (type (ident->type info array))
662                 (fields (or (type->description info type) '()))
663                 (size (type->size info type))
664                 (count (length fields))
665                 (field-size 4) ;; FIXME:4, not fixed
666                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
667                           (begin
668                             (stderr "no field:~a\n" field)
669                            '())))
670                 (offset (* field-size (1- (length rest))))
671                 (text (.text info)))
672            (clone info #:text
673                   (append text
674                           (.text index)
675                           (list (lambda (f g ta t d)
676                                   (append
677                                    (i386:accu->base)
678                                    (if (> count 1) (i386:accu+accu) '())
679                                    (if (= count 3) (i386:accu+base) '())
680                                    (i386:accu-shl 2))))
681                           ((ident->base info) array)
682                           (list (lambda (f g ta t d)
683                                   (i386:base-mem+n->accu offset)))))))
684         
685         ;;; FIXME: FROM INFO ...only zero?!
686         ((p-expr (fixed ,value))
687          (let ((value (cstring->number value)))
688           (clone info #:text
689                  (append text
690                          (list (lambda (f g ta t d)
691                                  (i386:value->accu value)))))))
692
693         ((p-expr (char ,char))
694          (let ((char (char->integer (car (string->list char)))))
695           (clone info #:text
696                  (append text
697                          (list (lambda (f g ta t d)
698                                  (i386:value->accu char)))))))
699
700         ((p-expr (ident ,name))
701          (clone info #:text
702                 (append text
703                         ((ident->accu info) name))))
704
705         ((de-ref (p-expr (ident ,name)))
706          (let* ((type (ident->type info name))
707                 (size (and type (type->size info type))))
708           (clone info #:text
709                  (append text
710                          ((ident->accu info) name)
711                          (list (lambda (f g ta t d)
712                                  (if (= size 1)
713                                      (i386:byte-mem->accu)
714                                      (i386:mem->accu))))))))
715
716         ;; GRR --> info again??!?
717         ((fctn-call . ,call)
718          ((ast->info info) `(expr-stmt ,o)))
719
720         ((cond-expr . ,cond-expr)
721          ((ast->info info) `(expr-stmt ,o)))
722
723         ;; FIXME
724         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
725         ((post-inc (p-expr (ident ,name)))
726          (clone info #:text
727                 (append text
728                         ((ident->accu info) name)
729                         ((ident-add info) name 1))))
730
731         ;; GRR --> info again??!?
732         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
733         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
734         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
735         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
736
737         ((add (p-expr (ident ,name)) ,b)
738          (let* ((empty (clone info #:text '()))
739                 (base ((expr->base empty) b)))
740            (clone info #:text
741                   (append text
742                           (.text base)
743                           ((ident->accu info) name)
744                           (list (lambda (f g ta t d)
745                                   (i386:accu+base)))))))
746
747         ((add ,a ,b)
748          (let* ((empty (clone info #:text '()))
749                 (accu ((expr->accu empty) a))
750                 (base ((expr->base empty) b)))
751            (clone info #:text
752                   (append text
753                           (.text accu)
754                           (.text base)
755                           (list (lambda (f g ta t d)
756                                   (i386:accu+base)))))))        
757
758         ((sub ,a ,b)
759          (let* ((empty (clone info #:text '()))
760                 (accu ((expr->accu empty) a))
761                 (base ((expr->base empty) b)))
762            (clone info #:text
763                   (append text
764                           (.text accu)
765                           (.text base)
766                           (list (lambda (f g ta t d)
767                                   (i386:accu-base)))))))        
768
769         ((bitwise-or ,a ,b)
770          (let* ((empty (clone info #:text '()))
771                 (accu ((expr->accu empty) a))
772                 (base ((expr->base empty) b)))
773            (clone info #:text
774                   (append text
775                           (.text accu)
776                           (.text base)
777                           (list (lambda (f g ta t d)
778                                   (i386:accu-or-base)))))))
779
780         ((lshift ,a ,b)
781          (let* ((empty (clone info #:text '()))
782                 (accu ((expr->accu empty) a))
783                 (base ((expr->base empty) b)))
784            (clone info #:text
785                   (append text
786                           (.text accu)
787                           (.text base)
788                           (list (lambda (f g ta t d)
789                                   (i386:accu<<base)))))))
790
791         ((rshift ,a ,b)
792          (let* ((empty (clone info #:text '()))
793                 (accu ((expr->accu empty) a))
794                 (base ((expr->base empty) b)))
795            (clone info #:text
796                   (append text
797                           (.text accu)
798                           (.text base)
799                           (list (lambda (f g ta t d)
800                                   (i386:accu>>base)))))))
801
802         ((div ,a ,b)
803          (let* ((empty (clone info #:text '()))
804                 (accu ((expr->accu empty) a))
805                 (base ((expr->base empty) b)))
806            (clone info #:text
807                   (append text
808                           (.text accu)
809                           (.text base)
810                           (list (lambda (f g ta t d)
811                                   (i386:accu/base)))))))
812
813         ((mod ,a ,b)
814          (let* ((empty (clone info #:text '()))
815                 (accu ((expr->accu empty) a))
816                 (base ((expr->base empty) b)))
817            (clone info #:text
818                   (append text ;;FIXME:empty
819                           (.text accu)
820                           (.text base)
821                           (list (lambda (f g ta t d)
822                                   (i386:accu%base)))))))
823
824         ((mul ,a ,b)
825          (let* ((empty (clone info #:text '()))
826                 (accu ((expr->accu empty) a))
827                 (base ((expr->base empty) b)))
828            (clone info #:text
829                   (append text
830                           (.text accu)
831                           (.text base)
832                           (list (lambda (f g ta t d)
833                                   (i386:accu*base)))))))
834
835         ;; FIXME: c/p ast->info
836         ((eq ,a ,b)
837          (let* ((base ((expr->base info) a))
838                 (empty (clone base #:text '()))
839                 (accu ((expr->accu empty) b)))
840            (clone info #:text
841                   (append (.text base)
842                           (list (lambda (f g ta t d)
843                                   (i386:push-base)))
844                           (.text accu)
845                           (list (lambda (f g ta t d)
846                                   (i386:pop-base)))
847                           (list (lambda (f g ta t d)
848                                   (i386:sub-base)))))))
849
850         ;; FIXME: c/p ast->info
851         ((lt ,a ,b)
852          (let* ((base ((expr->base info) a))
853                 (empty (clone base #:text '()))
854                 (accu ((expr->accu empty) b)))
855            (clone info #:text
856                   (append (.text base)
857                           (.text accu)
858                           (list (lambda (f g ta t d)
859                                   (i386:base-sub)))))))
860
861         ;; FIXME: ...c/p ast->info
862         ((neg (p-expr (ident ,name)))
863          (clone info #:text (append text
864                                     ((ident->base info) name)
865                                     (list (lambda (f g ta t d)
866                                             (i386:value->accu 0)))
867                                     (list (lambda (f g ta t d)
868                                             (i386:sub-base))))))
869
870         ;;((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"))))))
871         ((cast ,cast ,o)
872          ((expr->accu info) o))
873
874         ((assn-expr (p-expr (ident ,name)) ,op ,expr)
875          (let ((info ((ast->info info) o)))
876            (clone info #:text (append (.text info)
877                                       ((ident->accu info) name)))))
878
879         (_
880          (format (current-error-port) "SKIP: expr->accu=~s\n" o)
881          barf
882          info)))))
883
884 (define (expr->base info)
885   (lambda (o)
886     (let ((info ((expr->accu info) o)))
887       (clone info
888              #:text (append
889                      (list (lambda (f g ta t d)
890                              (i386:push-accu)))
891                      (.text info)
892                      (list (lambda (f g ta t d)
893                              (append
894                               (i386:accu->base)
895                               (i386:pop-accu)))))))))
896
897 (define (expr->accu* info)
898   (lambda (o)
899     (pmatch o
900       ;;(stderr "expr->accu* o=~s\n" o)
901       ;; g_cells[10].type
902       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
903        (let* ((type (ident->type info array))
904               (fields (or (type->description info type) '()))
905               (size (type->size info type))
906               (count (length fields))
907               (field-size 4) ;; FIXME:4, not fixed
908               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
909               (index (cstring->number index))
910               (text (.text info)))
911          (clone info #:text
912                 (append text
913                         (list (lambda (f g ta t d)
914                                 (append
915                                  (i386:value->base index)
916                                  (i386:base->accu)
917                                  (if (> count 1) (i386:accu+accu) '())
918                                  (if (= count 3) (i386:accu+base) '())
919                                  (i386:accu-shl 2))))
920                         ;; de-ref: g_cells, non: arena
921                         ;;((ident->base info) array)
922                         ((ident->base info) array)
923                         (list (lambda (f g ta t d)
924                                 (append
925                                  (i386:accu+base)
926                                  (i386:accu+value offset))))))))
927
928       ;; g_cells[x].type
929       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
930        (let* ((type (ident->type info array))
931               (fields (or (type->description info type) '()))
932               (size (type->size info type))
933               (count (length fields))
934               (field-size 4) ;; FIXME:4, not fixed
935               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
936               (text (.text info)))
937          (clone info #:text
938                 (append text
939                         ((ident->base info) index)
940                         (list (lambda (f g ta t d)
941                                 (append
942                                  (i386:base->accu)
943                                  (if (> count 1) (i386:accu+accu) '())
944                                  (if (= count 3) (i386:accu+base) '())
945                                  (i386:accu-shl 2))))
946                         ;; de-ref: g_cells, non: arena
947                         ;;((ident->base info) array)
948                         ((ident->base info) array)
949                         (list (lambda (f g ta t d)
950                                 (append
951                                  (i386:accu+base)
952                                  (i386:accu+value offset))))))))
953
954       ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
955       ((d-sel (ident ,field) (p-expr (ident ,name)))
956        (let* ((type (ident->type info name))
957               (fields (or (type->description info type) '()))
958               (field-size 4) ;; FIXME
959               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
960               (text (.text info)))
961          (clone info #:text
962                 (append text
963                         ((ident->accu info) name)
964                         (list (lambda (f g ta t d)
965                                 (i386:accu+value offset)))))))
966
967       (_
968        (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
969        barf
970        info)
971       )))
972
973 (define (ident->constant name value)
974   (cons name value))
975
976 (define (make-type name type size description)
977   (cons name (list type size description)))
978
979 (define (enum->type name fields)
980   (make-type name 'enum 4 fields))
981
982 (define (struct->type name fields)
983   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
984
985 (define (decl->type o)
986   (pmatch o
987     ((fixed-type ,type) type)
988     ((struct-ref (ident ,name)) (list "struct" name))
989     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
990      (list "struct" name)) ;; FIXME
991     ((typename ,name) name)
992     (_
993      (stderr "SKIP: decl type=~s\n" o)
994      barf
995      o)))
996
997 (define (expr->global o)
998   (pmatch o
999     ((p-expr (string ,string)) (string->global string))
1000     (_ #f)))
1001
1002 (define (initzer->global o)
1003   (pmatch o
1004     ((initzer ,initzer) (expr->global initzer))
1005     (_ #f)))
1006
1007 (define (byte->hex o)
1008   (string->number (string-drop o 2) 16))
1009
1010 (define (asm->hex o)
1011   (let ((prefix ".byte "))
1012     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
1013         (let ((s (string-drop o (string-length prefix))))
1014           (map byte->hex (string-split s #\space))))))
1015
1016 (define (case->jump-info info)
1017   (define (jump n)
1018     (list (lambda (f g ta t d) (i386:Xjump n))))
1019   (define (jump-nz n)
1020     (list (lambda (f g ta t d) (i386:Xjump-nz n))))
1021   (define (statement->info info body-length)
1022     (lambda (o)
1023       (pmatch o
1024         ((break) (clone info #:text (append (.text info) (jump body-length)
1025 )))
1026         (_
1027          ((ast->info info) o)))))
1028   (lambda (o)
1029     (pmatch o
1030       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
1031        (lambda (body-length)
1032
1033          (define (test->text value clause-length)
1034            (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1035                    (jump-nz clause-length)))
1036          (let* ((value (assoc-ref (.constants info) constant))
1037                 (test-info
1038                  (clone info #:text (append (.text info) (test->text value 0))))
1039                 (text-length (length (.text test-info)))
1040                 (clause-info (let loop ((elements elements) (info test-info))
1041                                (if (null? elements) info
1042                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1043                 (clause-text (list-tail (.text clause-info) text-length))
1044                 (clause-length (length (text->list clause-text))))
1045            (clone info #:text (append
1046                                (.text info)
1047                                (test->text value clause-length)
1048                                clause-text)
1049                   #:globals (.globals clause-info)))))
1050
1051       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
1052        (lambda (body-length)
1053
1054          (define (test->text value clause-length)
1055            (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1056                    (jump-nz clause-length)))
1057          (let* ((value (cstring->number value))
1058                 (test-info
1059                  (clone info #:text (append (.text info) (test->text value 0))))
1060                 (text-length (length (.text test-info)))
1061                 (clause-info (let loop ((elements elements) (info test-info))
1062                                (if (null? elements) info
1063                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1064                 (clause-text (list-tail (.text clause-info) text-length))
1065                 (clause-length (length (text->list clause-text))))
1066            (clone info #:text (append
1067                                (.text info)
1068                                (test->text value clause-length)
1069                                clause-text)
1070                   #:globals (.globals clause-info)))))
1071
1072       ((case (neg (p-expr (fixed ,value))) ,statement)
1073        ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
1074
1075       ((default (compd-stmt (block-item-list . ,elements)))
1076        (lambda (body-length)
1077          (let ((text-length (length (.text info))))
1078           (let loop ((elements elements) (info info))
1079             (if (null? elements) info
1080                 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
1081
1082       ((case (p-expr (ident ,constant)) ,statement)
1083        ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
1084
1085       ((case (p-expr (fixed ,value)) ,statement)
1086        ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
1087
1088       ((default ,statement)
1089        ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
1090
1091       (_ (stderr "no case match: ~a\n" o) barf)
1092       )))
1093
1094 (define (test->jump->info info)
1095   (define (jump type . test)
1096     (lambda (o)
1097       (let* ((text (.text info))
1098              (info (clone info #:text '()))
1099              (info ((ast->info info) o))
1100              (jump-text (lambda (body-length)
1101                           (list (lambda (f g ta t d) (type body-length))))))
1102        (lambda (body-length)
1103          (clone info #:text
1104                 (append text
1105                         (.text info)
1106                         (if (null? test) '() (car test))
1107                         (jump-text body-length)))))))
1108   (lambda (o)
1109     (pmatch o
1110       ;; unsigned
1111       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1112       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
1113       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1114       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1115
1116       ((le ,a ,b) ((jump i386:Xjump-g) o))
1117       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1118       ((ge ,a ,b) ((jump i386:Xjump-g) o))
1119       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1120
1121       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1122       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1123       ((not _) ((jump i386:Xjump-z) o))
1124       ((and ,a ,b)
1125        (let* ((text (.text info))
1126               (info (clone info #:text '()))
1127
1128               (a-jump ((test->jump->info info) a))
1129               (a-text (.text (a-jump 0)))
1130               (a-length (length (text->list a-text)))
1131
1132               (b-jump ((test->jump->info info) b))
1133               (b-text (.text (b-jump 0)))
1134               (b-length (length (text->list b-text))))
1135
1136          (lambda (body-length)
1137            (clone info #:text
1138                   (append text
1139                           (.text (a-jump (+ b-length body-length)))
1140                           (.text (b-jump body-length)))))))
1141       ((or ,a ,b)
1142        (let* ((text (.text info))
1143               (info (clone info #:text '()))
1144
1145               (a-jump ((test->jump->info info) a))
1146               (a-text (.text (a-jump 0)))
1147               (a-length (length (text->list a-text)))
1148
1149               (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1150               (jump-length (length (text->list jump-text)))
1151
1152               (b-jump ((test->jump->info info) b))
1153               (b-text (.text (b-jump 0)))
1154               (b-length (length (text->list b-text)))
1155
1156               (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
1157
1158          (lambda (body-length)
1159            (clone info #:text
1160                   (append text
1161                           (.text (a-jump jump-length))
1162                           jump-text
1163                           (.text (b-jump body-length)))))))
1164
1165       ((array-ref . _) ((jump i386:jump-byte-z
1166                               (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1167
1168       ((de-ref _) ((jump i386:jump-byte-z
1169                          (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1170
1171       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1172        ((jump i386:Xjump-z
1173               (append
1174                ((ident->accu info) name)
1175                (list (lambda (f g ta t d) (i386:accu-zero?))))) o))
1176
1177       (_ ((jump i386:Xjump-z (list (lambda (f g ta t d) (i386:accu-zero?)))) o)))))
1178
1179 (define (cstring->number s)
1180   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1181         ((string-prefix? "0" s) (string->number s 8))
1182         (else (string->number s))))
1183
1184 (define (struct-field o)
1185   (pmatch o
1186     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1187                 (comp-declr-list (comp-declr (ident ,name))))
1188      (cons type name))
1189     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1190      (cons type name))
1191     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1192      (cons type name))
1193     ((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)))))))))
1194      (cons type name)) ;; FIXME function / int
1195     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1196      (cons type name)) ;; FIXME: ptr/char
1197     (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1198
1199 (define (ast->type o)
1200   (pmatch o
1201     ((fixed-type ,type)
1202      type)
1203     ((struct-ref (ident ,type))
1204      (list "struct" type))
1205     (_ (stderr "SKIP: type=~s\n" o)
1206        "int")))
1207
1208 (define i386:type-alist
1209   '(("char" . (builtin 1 #f))
1210     ("int" . (builtin 4 #f))))
1211
1212 (define (type->size info o)
1213   ;;(stderr  "types=~s\n" (.types info))
1214   ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
1215   (pmatch o
1216     ((decl-spec-list (type-spec (fixed-type ,type)))
1217      (type->size info type))
1218     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1219      (type->size info type))
1220     (_ (let ((type (assoc-ref (.types info) o)))
1221          (if type (cadr type)
1222              (begin
1223                (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1224                barf
1225                4))))))
1226
1227 (define (ident->decl info o)
1228   ;; (stderr "ident->decl o=~s\n" o)
1229   ;; (stderr "  types=~s\n" (.types info))
1230   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
1231   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
1232   (or (assoc-ref (.locals info) o)
1233       (assoc-ref (.globals info) o)
1234       (begin
1235         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1236         (assoc-ref (.functions info) o))))
1237
1238 (define (ident->type info o)
1239   (and=> (ident->decl info o) car))
1240
1241 (define (ident->pointer info o)
1242   (let ((local (assoc-ref (.locals info) o)))
1243     (if local (local:pointer local)
1244         (or (and=> (ident->decl info o) global:pointer) 0))))
1245
1246 (define (type->description info o)
1247   ;; (stderr  "type->description =~s\n" o)  
1248   ;; (stderr  "types=~s\n" (.types info))
1249   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
1250   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
1251   (pmatch o
1252     ((decl-spec-list (type-spec (fixed-type ,type)))
1253      (type->description info type))
1254     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1255      (type->description info type))
1256     (_ (caddr (assoc-ref (.types info) o)))))
1257
1258 (define (local? o) ;; formals < 0, locals > 0
1259   (positive? (local:id o)))
1260
1261 (define (ast->info info)
1262   (lambda (o)
1263     (let ((globals (.globals info))
1264           (locals (.locals info))
1265           (constants (.constants info))
1266           (text (.text info)))
1267       (define (add-local locals name type pointer)
1268         (let* ((id (1+ (length (filter local? (map cdr locals)))))
1269                (locals (cons (make-local name type pointer id) locals)))
1270           locals))
1271
1272       ;; (stderr "\n ast->info=~s\n" o)
1273       ;; (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)))
1274       ;; (stderr "  text=~a\n" text)
1275       ;; (stderr "   info=~a\n" info)
1276       ;; (stderr "   globals=~a\n" globals)
1277       (pmatch o
1278         (((trans-unit . _) . _)
1279          ((ast-list->info info)  o))
1280         ((trans-unit . ,elements)
1281          ((ast-list->info info) elements))
1282         ((fctn-defn . _) ((function->info info) o))
1283         ((comment . _) info)
1284         ((cpp-stmt (define (name ,name) (repl ,value)))
1285          info)
1286
1287         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1288          info)
1289
1290         ;; FIXME: expr-stmt wrapper?
1291         (trans-unit info)
1292         ((expr-stmt) info)
1293         ((assn-expr . ,assn-expr)
1294          ((ast->info info) `(expr-stmt ,o)))
1295
1296         ((d-sel . ,d-sel)
1297          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1298            expr))
1299
1300         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1301         
1302         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1303          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1304                                    (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1305              (let* ((globals (append globals (filter-map expr->global expr-list)))
1306                     (info (clone info #:globals globals))
1307                     (text-length (length text))
1308                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
1309                                  (if (null? expressions) info
1310                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1311                     (text (.text args-info))
1312                     (n (length expr-list)))
1313                (if (and (not (assoc-ref locals name))
1314                         (assoc-ref (.functions info) name))
1315                 (clone args-info #:text
1316                        (append text
1317                                (list (lambda (f g ta t d)
1318                                        (i386:call f g ta t d (+ t (function-offset name f)) n))))
1319                        #:globals globals)
1320                 (let* ((empty (clone info #:text '()))
1321                        (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1322                   (clone args-info #:text
1323                          (append text
1324                                  (.text accu)
1325                                  (list (lambda (f g ta t d)
1326                                          (i386:call-accu f g ta t d n))))
1327                          #:globals globals))))))
1328
1329         ;;((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))))
1330         ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1331          (let* ((globals (append globals (filter-map expr->global expr-list)))
1332                 (info (clone info #:globals globals))
1333                 (text-length (length text))
1334                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1335                              (if (null? expressions) info
1336                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1337                 (text (.text args-info))
1338                 (n (length expr-list))
1339                 (empty (clone info #:text '()))
1340                 (accu ((expr->accu empty) function)))
1341            (clone info #:text
1342                   (append text
1343                           (.text accu)
1344                           (list (lambda (f g ta t d)
1345                                   (i386:call-accu f g ta t d n))))
1346                   #:globals globals)))
1347
1348         ((if ,test ,body)
1349          (let* ((text-length (length text))
1350
1351                 (test-jump->info ((test->jump->info info) test))
1352                 (test+jump-info (test-jump->info 0))
1353                 (test-length (length (.text test+jump-info)))
1354
1355                 (body-info ((ast->info test+jump-info) body))
1356                 (text-body-info (.text body-info))
1357                 (body-text (list-tail text-body-info test-length))
1358                 (body-length (length (text->list body-text)))
1359
1360                 (text+test-text (.text (test-jump->info body-length)))
1361                 (test-text (list-tail text+test-text text-length)))
1362
1363            (clone info #:text
1364                   (append text
1365                           test-text
1366                           body-text)
1367                   #:globals (.globals body-info))))
1368
1369         ((if ,test ,then ,else)
1370          (let* ((text-length (length text))
1371
1372                 (test-jump->info ((test->jump->info info) test))
1373                 (test+jump-info (test-jump->info 0))
1374                 (test-length (length (.text test+jump-info)))
1375
1376                 (then-info ((ast->info test+jump-info) then))
1377                 (text-then-info (.text then-info))
1378                 (then-text (list-tail text-then-info test-length))
1379                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1380                 (then-jump-length (length (text->list then-jump-text)))
1381                 (then-length (+ (length (text->list then-text)) then-jump-length))
1382
1383                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1384                 (else-info ((ast->info then+jump-info) else))
1385                 (text-else-info (.text else-info))
1386                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1387                 (else-length (length (text->list else-text)))
1388
1389                 (text+test-text (.text (test-jump->info then-length)))
1390                 (test-text (list-tail text+test-text text-length))
1391                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1392
1393            (clone info #:text
1394                   (append text
1395                           test-text
1396                           then-text
1397                           then-jump-text
1398                           else-text)
1399                   #:globals (append (.globals then-info)
1400                                     (list-tail (.globals else-info) (length globals))))))
1401
1402         ((expr-stmt (cond-expr ,test ,then ,else))
1403          (let* ((text-length (length text))
1404
1405                 (test-jump->info ((test->jump->info info) test))
1406                 (test+jump-info (test-jump->info 0))
1407                 (test-length (length (.text test+jump-info)))
1408
1409                 (then-info ((ast->info test+jump-info) then))
1410                 (text-then-info (.text then-info))
1411                 (then-text (list-tail text-then-info test-length))
1412                 (then-length (length (text->list then-text)))
1413
1414                 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1415                 (jump-length (length (text->list jump-text)))
1416
1417                 (test+then+jump-info
1418                  (clone then-info
1419                         #:text (append (.text then-info) jump-text)))
1420
1421                 (else-info ((ast->info test+then+jump-info) else))
1422                 (text-else-info (.text else-info))
1423                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1424                 (else-length (length (text->list else-text)))
1425
1426                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1427                 (test-text (list-tail text+test-text text-length))
1428                 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1429
1430            (clone info #:text
1431                   (append text
1432                           test-text
1433                           then-text
1434                           jump-text
1435                           else-text)
1436                   #:globals (.globals else-info))))
1437
1438         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1439          (let* ((expr ((expr->accu info) expr))
1440                 (empty (clone info #:text '()))
1441                 (case-infos (map (case->jump-info empty) cases))
1442                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1443                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1444                               (if (null? cases) info
1445                                   (let ((c-j ((case->jump-info info) (car cases))))
1446                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1447            cases-info))
1448
1449         ((for ,init ,test ,step ,body)
1450          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1451
1452                 (info ((ast->info info) init))
1453
1454                 (init-text (.text info))
1455                 (init-locals (.locals info))
1456                 (info (clone info #:text '()))
1457
1458                 (body-info ((ast->info info) body))
1459                 (body-text (.text body-info))
1460                 (body-length (length (text->list body-text)))
1461
1462                 (step-info ((ast->info info) `(expr-stmt ,step)))
1463                 (step-text (.text step-info))
1464                 (step-length (length (text->list step-text)))
1465
1466                 (test-jump->info ((test->jump->info info) test))
1467                 (test+jump-info (test-jump->info 0))
1468                 (test-length (length (text->list (.text test+jump-info))))
1469
1470                 (skip-body-text (list (lambda (f g ta t d)
1471                                         (i386:Xjump (+ body-length step-length)))))
1472
1473                 (jump-text (list (lambda (f g ta t d)
1474                                    (i386:Xjump (- (+ body-length step-length test-length))))))
1475                 (jump-length (length (text->list jump-text)))
1476
1477                 (test-text (.text (test-jump->info jump-length))))
1478
1479            (clone info #:text
1480                   (append text
1481                           init-text
1482                           skip-body-text
1483                           body-text
1484                           step-text
1485                           test-text
1486                           jump-text)
1487                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1488                   #:locals locals)))
1489
1490         ;; FIXME: support break statement (see switch/case)
1491         ((while ,test ,body)
1492          (let* ((skip-info (lambda (body-length)
1493                              (clone info #:text (append text
1494                                                         (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
1495                 (text (.text (skip-info 0)))
1496                 (text-length (length text))
1497
1498                 (body-info (lambda (body-length)
1499                              ((ast->info (skip-info body-length)) body)))
1500                 (body-text (list-tail (.text (body-info 0)) text-length))
1501                 (body-length (length (text->list body-text)))
1502
1503                 (body-info (body-info body-length))
1504
1505                 (empty (clone info #:text '()))
1506                 (test-jump->info ((test->jump->info empty) test))
1507                 (test+jump-info (test-jump->info 0))
1508                 (test-length (length (text->list (.text test+jump-info))))
1509
1510                 (jump-text (list (lambda (f g ta t d)
1511                                    (i386:Xjump (- (+ body-length test-length))))))
1512                 (jump-length (length (text->list jump-text)))
1513
1514                 (test-text (.text (test-jump->info jump-length))))
1515            (clone info #:text
1516                   (append
1517                    (.text body-info)
1518                    test-text
1519                    jump-text)
1520                   #:globals (.globals body-info))))
1521
1522         ((do-while ,body ,test)
1523          (let* ((text-length (length text))
1524
1525                 (body-info ((ast->info info) body))
1526                 (body-text (list-tail (.text body-info) text-length))
1527                 (body-length (length (text->list body-text)))
1528
1529                 (empty (clone info #:text '()))
1530                 (test-jump->info ((test->jump->info empty) test))
1531                 (test+jump-info (test-jump->info 0))
1532                 (test-length (length (text->list (.text test+jump-info))))
1533
1534                 (jump-text (list (lambda (f g ta t d)
1535                                    (i386:Xjump (- (+ body-length test-length))))))
1536                 (jump-length (length (text->list jump-text)))
1537
1538                 (test-text (.text (test-jump->info jump-length))))
1539            (clone info #:text
1540                   (append
1541                    (.text body-info)
1542                    test-text
1543                    jump-text)
1544                   #:globals (.globals body-info))))
1545
1546         ((labeled-stmt (ident ,label) ,statement)
1547          (let ((info (clone info #:text (append text (list label)))))
1548            ((ast->info info) statement)))
1549
1550         ((goto (ident ,label))
1551          (let* ((jump (lambda (n) (i386:XXjump n)))
1552                 (offset (+ (length (jump 0)) (length (text->list text)))))
1553            (clone info #:text
1554                   (append text
1555                           (list (lambda (f g ta t d)
1556                                   (jump (- (label-offset (.function info) label f) offset))))))))
1557
1558         ;;; FIXME: only zero?!
1559         ((p-expr (ident ,name))
1560          (clone info #:text
1561                 (append text
1562                         ((ident->accu info) name)
1563                         (list (lambda (f g ta t d)
1564                                 (append
1565                                  (i386:accu-zero?)))))))
1566
1567         ((p-expr (fixed ,value))
1568          (let ((value (cstring->number value)))
1569           (clone info #:text
1570                  (append text
1571                          (list (lambda (f g ta t d)
1572                                  (append
1573                                   (i386:value->accu value)
1574                                   (i386:accu-zero?))))))))
1575
1576         ((de-ref (p-expr (ident ,name)))
1577          (clone info #:text
1578                 (append text
1579                         ((ident->accu info) name)
1580                         (list (lambda (f g ta t d)
1581                                 (append
1582                                  (i386:byte-mem->accu)))))))
1583
1584         ((fctn-call . ,call)
1585          (let ((info ((ast->info info) `(expr-stmt ,o))))
1586            (clone info #:text
1587                   (append (.text info)
1588                           (list (lambda (f g ta t d)
1589                                   (i386:accu-zero?)))))))
1590
1591         ;; FIXME
1592         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1593         ((post-inc (p-expr (ident ,name)))
1594          (clone info #:text
1595                 (append text
1596                         ((ident->accu info) name)
1597                         ((ident-add info) name 1)
1598                         (list (lambda (f g ta t d)
1599                                 (append
1600                                  (i386:accu-zero?)))))))
1601         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1602         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1603         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1604         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1605
1606         ;; i++
1607         ((expr-stmt (post-inc (p-expr (ident ,name))))
1608          (clone info #:text (append text ((ident-add info) name 1))))
1609
1610         ;; ++i
1611         ((expr-stmt (pre-inc (p-expr (ident ,name))))
1612          (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
1613          (clone info #:text
1614                 (append text
1615                         ((ident-add info) name 1)
1616                         ((ident->accu info) name)
1617                         (list (lambda (f g ta t d)
1618                                 (append
1619                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1620                                  (i386:accu-zero?)))))))
1621
1622         ;; i--
1623         ((expr-stmt (post-dec (p-expr (ident ,name))))
1624          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
1625          (clone info #:text
1626                 (append text
1627                         ((ident->accu info) name)
1628                         ((ident-add info) name -1)
1629                         (list (lambda (f g ta t d)
1630                                 (append
1631                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1632                                  (i386:accu-zero?)))))))
1633
1634         ;; --i
1635         ((expr-stmt (pre-dec (p-expr (ident ,name))))
1636          (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
1637          (clone info #:text
1638                 (append text
1639                         ((ident-add info) name -1)
1640                         ((ident->accu info) name)
1641                         (list (lambda (f g ta t d)
1642                                 (append
1643                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1644                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1645                                  (i386:accu-zero?)))))))
1646
1647         ((not ,expr)
1648          (let* ((test-info ((ast->info info) expr)))
1649            (clone info #:text
1650                   (append (.text test-info)
1651                           (list (lambda (f g ta t d)
1652                                   (append
1653                                    (i386:accu-not)
1654                                    (i386:accu-zero?)))))
1655                   #:globals (.globals test-info))))
1656
1657         ((eq ,a ,b)
1658          (let* ((base ((expr->base info) a))
1659                 (empty (clone base #:text '()))
1660                 (accu ((expr->accu empty) b)))
1661            (clone info #:text
1662                   (append text
1663                           (.text base)
1664                           (list (lambda (f g ta t d)
1665                                   (i386:push-base)))
1666                           (.text accu)
1667                           (list (lambda (f g ta t d)
1668                                   (i386:pop-base)))
1669                           (list (lambda (f g ta t d)
1670                                   (i386:sub-base)))))))
1671
1672         ((ge ,a ,b)
1673          (let* ((base ((expr->base info) a))
1674                 (empty (clone base #:text '()))
1675                 (accu ((expr->accu empty) b)))
1676            (clone info #:text
1677                   (append text
1678                           (.text base)
1679                           (list (lambda (f g ta t d)
1680                                   (i386:push-base)))
1681                           (.text accu)
1682                           (list (lambda (f g ta t d)
1683                                   (i386:pop-base)))
1684                           (list (lambda (f g ta t d)
1685                                   (i386:sub-base)))))))
1686
1687         ((gt ,a ,b)
1688          (let* ((base ((expr->base info) a))
1689                 (empty (clone base #:text '()))
1690                 (accu ((expr->accu empty) b)))
1691            (clone info #:text
1692                   (append text
1693                           (.text base)
1694                           (list (lambda (f g ta t d)
1695                                   (i386:push-base)))
1696                           (.text accu)
1697                           (list (lambda (f g ta t d)
1698                                   (i386:pop-base)))
1699                           (list (lambda (f g ta t d)
1700                                   (i386:sub-base)))))))
1701
1702         ((ne ,a ,b)
1703          (let* ((base ((expr->base info) a))
1704                 (empty (clone base #:text '()))
1705                 (accu ((expr->accu empty) b)))
1706            (clone info #:text
1707                   (append text
1708                           (.text base)
1709                           (list (lambda (f g ta t d)
1710                                   (i386:push-base)))
1711                           (.text accu)
1712                           (list (lambda (f g ta t d)
1713                                   (i386:pop-base)))
1714                           (list (lambda (f g ta t d)
1715                                   (append 
1716                                    (i386:sub-base)
1717                                    (i386:xor-zf))))))))
1718
1719         ((le ,a ,b)
1720          (let* ((base ((expr->base info) a))
1721                 (empty (clone base #:text '()))
1722                 (accu ((expr->accu empty) b)))
1723            (clone info #:text
1724                   (append text
1725                           (.text base)
1726                           (list (lambda (f g ta t d)
1727                                   (i386:push-base)))
1728                           (.text accu)
1729                           (list (lambda (f g ta t d)
1730                                   (i386:pop-base)))
1731                           (list (lambda (f g ta t d)
1732                                   (i386:base-sub)))))))
1733
1734         ((lt ,a ,b)
1735          (let* ((base ((expr->base info) a))
1736                 (empty (clone base #:text '()))
1737                 (accu ((expr->accu empty) b)))
1738            (clone info #:text
1739                   (append text
1740                           (.text base)
1741                           (list (lambda (f g ta t d)
1742                                   (i386:push-base)))
1743                           (.text accu)
1744                           (list (lambda (f g ta t d)
1745                                   (i386:pop-base)))
1746                           (list (lambda (f g ta t d)
1747                                   (i386:base-sub)))))))
1748
1749         ;; HMM
1750         ((lshift . _) ((expr->accu info) o))
1751         ((rshift . _) ((expr->accu info) o))
1752
1753         ;; TODO: byte dinges
1754         ((Xsub ,a ,b)
1755          (let* ((base ((expr->base info) a))
1756                 (empty (clone base #:text '()))
1757                 (accu ((expr->accu empty) b)))
1758            (clone info #:text
1759                   (append text
1760                           (.text base)
1761                           (list (lambda (f g ta t d)
1762                                   (i386:push-base)))
1763                           (.text accu)
1764                           (list (lambda (f g ta t d)
1765                                   (i386:pop-base)))
1766                           (list (lambda (f g ta t d)
1767                                   (i386:base-sub)))))))
1768
1769         ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1770          (clone info #:text
1771                 (append text
1772                         (list (lambda (f g ta t d)
1773                                 (append
1774                                  (i386:local->accu (local:id (assoc-ref locals a)))
1775                                  (i386:byte-mem->base)
1776                                  (i386:local->accu (local:id (assoc-ref locals b)))
1777                                  (i386:byte-mem->accu)
1778                                  (i386:byte-sub-base)))))))
1779
1780         ;; g_cells[0]
1781         ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
1782          (let* ((value (cstring->number value))
1783                 (type (ident->type info array))
1784                 (size (type->size info type)))
1785            (clone info #:text
1786                   (append text
1787                         ((ident->base info) array)
1788                         (list (lambda (f g ta t d)
1789                                 (append
1790                                  (i386:value->accu (* size index))
1791                                  (if (eq? size 1)
1792                                      (i386:byte-base-mem->accu)
1793                                      (i386:base-mem->accu)))))))))
1794         
1795         ;; g_cells[a]
1796         ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1797          (let* ((type (ident->type info array))
1798                 (size (type->size info type)))
1799            (clone info #:text
1800                   (append text
1801                           ((ident->base info) index)
1802                           (list (lambda (f g ta t d)
1803                                   (append
1804                                    (i386:base->accu)
1805                                    (if (< size 4) '()
1806                                        (append
1807                                          (i386:accu+accu)
1808                                          (if (= size 12) (i386:accu+base) '())
1809                                          (i386:accu-shl 2))))))
1810                           ((ident->base info) array)
1811                           (list (lambda (f g ta t d)
1812                                  (if (eq? size 1)
1813                                      (i386:byte-base-mem->accu)
1814                                      (i386:base-mem->accu))))))))
1815         
1816         ((return ,expr)
1817          (let ((accu ((expr->accu info) expr)))
1818            (clone accu #:text
1819                   (append (.text accu) (list (lambda (f g ta t d) (i386:ret)))))))
1820
1821         ;; int i;
1822         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1823          (if (.function info)
1824              (clone info #:locals (add-local locals name type 0))
1825              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1826
1827         ;; int i = 0;
1828         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1829          (let ((value (cstring->number value)))
1830            (if (.function info)
1831                (let* ((locals (add-local locals name type 0))
1832                       (info (clone info #:locals locals)))
1833                  (clone info #:text
1834                         (append text
1835                                 ((value->ident info) name value))))
1836                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1837
1838         ;; char c = 'A';
1839         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1840          (if (not (.function info)) decl-barf0)
1841          (let* ((locals (add-local locals name type 0))
1842                 (info (clone info #:locals locals))
1843                 (value (char->integer (car (string->list value)))))
1844            (clone info #:text
1845                   (append text
1846                           ((value->ident info) name value)))))
1847
1848         ;; int i = -1;
1849         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1850          (let ((value (- (cstring->number value))))
1851            (if (.function info)
1852                (let* ((locals (add-local locals name type 0))
1853                       (info (clone info #:locals locals)))
1854                  (clone info #:text
1855                         (append text
1856                                 ((value->ident info) name value))))
1857                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1858
1859         ;; int i = argc;
1860         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1861          (if (not (.function info)) decl-barf2)
1862          (let* ((locals (add-local locals name type 0))
1863                 (info (clone info #:locals locals)))
1864            (clone info #:text
1865                   (append text
1866                           ((ident->accu info) local)
1867                           ((accu->ident info) name)))))
1868
1869         ;; char *p = "t.c";
1870         ;;(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"))))))
1871         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1872          (when (not (.function info))
1873              (stderr "o=~s\n" o)
1874              decl-barf3)
1875          (let* ((locals (add-local locals name type 1))
1876                 (globals (append globals (list (string->global string))))
1877                 (info (clone info #:locals locals #:globals globals)))
1878            (clone info #:text
1879                   (append text
1880                           (list (lambda (f g ta t d)
1881                                   (append
1882                                    (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1883                           ((accu->ident info) name)))))
1884         
1885         ;; char *p = 0;
1886         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1887          (let ((value (cstring->number value)))
1888            (if (.function info)
1889                (let* ((locals (add-local locals name type 1))
1890                       (info (clone info #:locals locals)))
1891                  (clone info #:text
1892                         (append text
1893                                 (list (lambda (f g ta t d)
1894                                         (i386:value->accu value)))
1895                                 ((accu->ident info) name))))
1896                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1897
1898         ;; char arena[20000];
1899         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1900          (let ((type (ast->type type)))
1901            (if (.function info)
1902                TODO:decl-array 
1903                (let* ((globals (.globals info))
1904                       (count (cstring->number count))
1905                       (size (type->size info type))
1906                       ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1907                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1908                       (globals (append globals (list array))))
1909                  (clone info
1910                         #:globals globals)))))
1911
1912         ;;struct scm *g_cells = (struct scm*)arena;
1913         ((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)))))))
1914          ;;(stderr "0TYPE: ~s\n" type)
1915          (if (.function info)
1916              (let* ((locals (add-local locals name type 1))
1917                     (info (clone info #:locals locals)))
1918                (clone info #:text
1919                       (append text
1920                               ((ident->accu info) name)
1921                               ((accu->ident info) value)))) ;; FIXME: deref?
1922              (let* ((globals (append globals (list (ident->global name type 1 0))))
1923                     (info (clone info #:globals globals)))
1924                (clone info #:text
1925                       (append text
1926                               ((ident->accu info) name)
1927                               ((accu->ident info) value)))))) ;; FIXME: deref?
1928
1929         ;; SCM tmp;
1930         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1931          ;;(stderr  "1TYPE: ~s\n" type)
1932          (if (.function info)
1933              (clone info #:locals (add-local locals name type 0))
1934              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1935
1936         ;; SCM g_stack = 0;
1937         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1938          ;;(stderr  "2TYPE: ~s\n" type)
1939          (let ((value (cstring->number value)))
1940           (if (.function info)
1941               (let* ((locals (add-local locals name type 0))
1942                      (info (clone info #:locals locals)))
1943                 (clone info #:text
1944                        (append text
1945                                ((value->ident info) name value))))
1946               (let ((globals (append globals (list (ident->global name type 0 value)))))
1947                 (clone info #:globals globals)))))
1948
1949         ;; SCM g_stack = 0; // comment
1950         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1951          ((ast->info info) (list-head o (- (length o) 1))))
1952
1953         ;; SCM i = argc;
1954         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1955          ;;(stderr  "3TYPE: ~s\n" type)
1956          (if (.function info)
1957              (let* ((locals (add-local locals name type 0))
1958                     (info (clone info #:locals locals)))
1959                (clone info #:text
1960                       (append text
1961                               ((ident->accu info) local)
1962                               ((accu->ident info) name))))
1963              (let* ((globals (append globals (list (ident->global name type 0 0))))
1964                     (info (clone info #:globals globals)))
1965                (clone info #:text
1966                       (append text
1967                               ((ident->accu info) local)
1968                               ((accu->ident info) name))))))
1969
1970         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1971         ((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))))
1972          (let* ((locals (add-local locals name type 1))
1973                 (info (clone info #:locals locals))
1974                 (empty (clone info #:text '()))
1975                 (accu ((expr->accu empty) initzer)))
1976            (clone info
1977                   #:text
1978                   (append text
1979                           (.text accu)
1980                           ((accu->ident info) name)
1981                           (list (lambda (f g ta t d)
1982                                   (append
1983                                    ;;(i386:value->base t)
1984                                    ;;(i386:accu+base)
1985                                    (i386:value->base ta)
1986                                    (i386:accu+base)))))
1987                   #:locals locals)))
1988
1989         ;; char *p = (char*)g_cells;
1990         ((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)))))))
1991          ;;(stderr  "6TYPE: ~s\n" type)
1992          (if (.function info)
1993              (let* ((locals (add-local locals name type 1))
1994                     (info (clone info #:locals locals)))
1995                (clone info #:text
1996                       (append text
1997                               ((ident->accu info) value)
1998                               ((accu->ident info) name))))
1999              (let* ((globals (append globals (list (ident->global name type 1 0))))
2000                     (here (data-offset name globals))
2001                     (there (data-offset value globals)))
2002                (clone info
2003                       #:globals globals
2004                       #:init (append (.init info)
2005                                      (list (lambda (functions globals ta t d data)
2006                                              (append
2007                                               (list-head data here)
2008                                               ;;; FIXME: type
2009                                               ;;; char *x = arena;
2010                                               (int->bv32 (+ d (data-offset value globals)))
2011                                               ;;; char *y = x;
2012                                               ;;;(list-head (list-tail data there) 4)
2013                                               (list-tail data (+ here 4))))))))))
2014
2015         ;; char *p = g_cells;
2016         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
2017          ;;(stderr  "7TYPE: ~s\n" type)
2018          (let ((type (decl->type type)))
2019            ;;(stderr "0DECL: ~s\n" type)
2020            (if (.function info)
2021                (let* ((locals (add-local locals name type  1))
2022                       (info (clone info #:locals locals)))
2023                  (clone info #:text
2024                         (append text
2025                                 ((ident->accu info) value)
2026                                 ((accu->ident info) name))))
2027                (let* ((globals (append globals (list (ident->global name type 1 0))))
2028                       (here (data-offset name globals)))
2029                  (clone info
2030                         #:globals globals
2031                         #:init (append (.init info)
2032                                        (list (lambda (functions globals ta t d data)
2033                                                (append
2034                                                 (list-head data here)
2035                                               ;;; FIXME: type
2036                                               ;;; char *x = arena;p
2037                                                 (int->bv32 (+ d (data-offset value globals)))
2038                                                 (list-tail data (+ here 4)))))))))))
2039
2040         ;; enum 
2041         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
2042          (let ((type (enum->type name fields))
2043                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
2044            (clone info
2045                   #:types (append (.types info) (list type))
2046                   #:constants (append constants (.constants info)))))
2047
2048         ;; struct
2049         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
2050          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
2051            ;;(stderr "type: ~a\n" type)
2052            (clone info #:types (append (.types info) (list type)))))
2053
2054         ;; *p++ = b;
2055         ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
2056          (when (not (equal? op "="))
2057            (stderr "OOOPS0.0: op=~s\n" op)
2058            barf)
2059          (let* ((empty (clone info #:text '()))
2060                 (base ((expr->base empty) b)))
2061            (clone info #:text
2062                   (append text
2063                           (.text base)
2064                           ((base->ident-address info) name)
2065                           ((ident-add info) name 1)))))
2066
2067         ;; *p-- = b;
2068         ((expr-stmt (assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b))
2069          (when (not (equal? op "="))
2070            (stderr "OOOPS0.0: op=~s\n" op)
2071            barf)
2072          (let* ((empty (clone info #:text '()))
2073                 (base ((expr->base empty) b)))
2074            (clone info #:text
2075                   (append text
2076                           (.text base)
2077                           ((base->ident-address info) name)
2078                           ((ident-add info) name -1)))))
2079
2080         ;; CAR (x) = 0
2081         ;; TYPE (x) = PAIR;
2082         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
2083          (when (not (equal? op "="))
2084            (stderr "OOOPS0: op=~s\n" op)
2085            barf)
2086          (let* ((empty (clone info #:text '()))
2087                 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
2088                 (base ((expr->base empty) b))
2089                 (type (list "struct" "scm")) ;; FIXME
2090                 (fields (type->description info type))
2091                 (size (type->size info type))
2092                 (field-size 4) ;; FIXME:4, not fixed
2093                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
2094            (clone info #:text (append text
2095                                       (.text expr)
2096                                       (.text base)
2097                                       (list (lambda (f g ta t d)
2098                                               ;;(i386:byte-base->accu-ref) ;; FIXME: size
2099                                               (i386:base->accu-address)
2100                                               ))))))
2101
2102
2103         ;; i = 0;
2104         ;; c = f ();
2105         ;; i = i + 48;
2106         ;; p = g_cell;
2107         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
2108          (when (and (not (equal? op "="))
2109                     (not (equal? op "+="))
2110                     (not (equal? op "-=")))
2111            (stderr "OOOPS1: op=~s\n" op)
2112            barf)
2113          (let* ((empty (clone info #:text '()))
2114                 (base ((expr->base empty) b)))
2115            (clone info #:text (append text
2116                                       (.text base)
2117                                       (if (equal? op "=") '()
2118                                           (append ((ident->accu info) name)
2119                                                   (list (lambda (f g ta t d)
2120                                                           (append
2121                                                            (if (equal? op "+=")
2122                                                                (i386:accu+base)
2123                                                                (i386:accu-base))
2124                                                            (i386:accu->base))))))
2125                                       ;;assign:
2126                                       ((base->ident info) name)))))
2127         
2128         ;; *p = 0;
2129         ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
2130          (when (not (equal? op "="))
2131            (stderr "OOOPS2: op=~s\n" op)
2132            barf)
2133          (let* ((empty (clone info #:text '()))
2134                 (base ((expr->base empty) b)))
2135            (clone info #:text (append text
2136                                       (.text base)
2137                                       ;;assign:
2138                                       ((base->ident-address info) array)))))
2139
2140         ;; g_cells[0] = 65;
2141         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2142          (when (not (equal? op "="))
2143            (stderr "OOOPS3: op=~s\n" op)
2144            barf)
2145          (let* ((index (cstring->number index))
2146                 (empty (clone info #:text '()))
2147                 (base ((expr->base empty) b))
2148                 (type (ident->type info array))
2149                 (size (type->size info type))
2150                 (ptr (ident->pointer info array)))
2151            (clone info #:text
2152                   (append text
2153                          (.text base)
2154                          (list (lambda (f g ta t d)
2155                                  (i386:push-base)))
2156                          (list (lambda (f g ta t d)
2157                                  (append
2158                                   (i386:value->base index)
2159                                   (i386:base->accu)
2160                                   (if (eq? size 1) '()
2161                                       (append
2162                                         (if (> size 4) (i386:accu+accu) '())
2163                                         (if (> size 8) (i386:accu+base) '())
2164                                         (i386:accu-shl 2))))))
2165                          ((ident->base info) array)
2166                          (list (lambda (f g ta t d)
2167                                  (i386:accu+base)))
2168                          (list (lambda (f g ta t d)
2169                                  (i386:pop-base)))
2170                          (if (eq? size 1) (list (lambda (f g ta t d)
2171                                                   (i386:byte-base->accu-address)))
2172                              (append
2173                               (list (lambda (f g ta t d)
2174                                       (i386:base-address->accu-address)))
2175                               (if (> size 4)
2176                                   (list (lambda (f g ta t d)
2177                                           (append
2178                                            (i386:accu+n 4)
2179                                            (i386:base+n 4)
2180                                            (i386:base-address->accu-address))))
2181                                   '())
2182                               (if (> size 8)
2183                                   (list (lambda (f g ta t d)
2184                                           (append
2185                                            (i386:accu+n 4)
2186                                            (i386:base+n 4)
2187                                            (i386:base-address->accu-address))))
2188                                   '())))))))
2189
2190         ;; g_cells[i] = c;
2191         ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2192          ;;(stderr "pointer_cells4[]: ~s\n" array)
2193          (when (not (equal? op "="))
2194            (stderr "OOOPS4: op=~s\n" op)
2195            barf)
2196          (let* ((empty (clone info #:text '()))
2197                 (base ((expr->base empty) b))
2198                 (type (ident->type info array))
2199                 (size (type->size info type))
2200                 (ptr (ident->pointer info array)))
2201            (clone info #:text
2202                   (append text
2203                           (.text base)
2204                           (list (lambda (f g ta t d)
2205                                   (i386:push-base)))
2206                           ((ident->base info) index)
2207                           (list (lambda (f g ta t d)
2208                                   (append
2209                                    (i386:base->accu)
2210                                    (if (eq? size 1) '()
2211                                        (append
2212                                          (if (> size 4) (i386:accu+accu) '())
2213                                          (if (> size 8) (i386:accu+base) '())
2214                                          (i386:accu-shl 2))))))
2215                           ((ident->base info) array)
2216                           (list (lambda (f g ta t d)
2217                                   (i386:accu+base)))
2218                          (list (lambda (f g ta t d)
2219                                  (i386:pop-base)))
2220                          (if (eq? size 1) (list (lambda (f g ta t d)
2221                                                   (i386:byte-base->accu-address)))
2222                              (append
2223                               (list (lambda (f g ta t d)
2224                                       (i386:base-address->accu-address)))
2225                               (if (> size 4)
2226                                   (list (lambda (f g ta t d)
2227                                           (append
2228                                            (i386:accu+n 4)
2229                                            (i386:base+n 4)
2230                                            (i386:base-address->accu-address))))
2231                                   '())
2232                               (if (> size 8)
2233                                   (list (lambda (f g ta t d)
2234                                           (append
2235                                            (i386:accu+n 4)
2236                                            (i386:base+n 4)
2237                                            (i386:base-address->accu-address))))
2238                                   '())))))))
2239
2240         ;; g_functions[g_function++] = g_foo;
2241         ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
2242          (when (not (equal? op "="))
2243            (stderr "OOOPS5: op=~s\n" op)
2244            barf)
2245          (let* ((empty (clone info #:text '()))
2246                 (base ((expr->base empty) b))
2247                 (type (ident->type info array))
2248                 (size (type->size info type))
2249                 (ptr (ident->pointer info array)))
2250            (clone info #:text
2251                   (append text
2252                           (.text base)
2253                           (list (lambda (f g ta t d)
2254                                   (i386:push-base)))
2255                           ((ident->base info) index)
2256                           (list (lambda (f g ta t d)
2257                                   (append
2258                                    (i386:base->accu)
2259                                    (if (eq? size 1) '()
2260                                        (append
2261                                          (if (> size 4) (i386:accu+accu) '())
2262                                          (if (> size 8) (i386:accu+base) '())
2263                                          (i386:accu-shl 2))))))
2264                           ((ident->base info) array)
2265                           (list (lambda (f g ta t d)
2266                                   (i386:accu+base)))
2267                          (list (lambda (f g ta t d)
2268                                  (i386:pop-base)))
2269                          (if (eq? size 1) (list (lambda (f g ta t d)
2270                                                   (i386:byte-base->accu-address)))
2271                              (append
2272                               (list (lambda (f g ta t d)
2273                                       (i386:base-address->accu-address)))
2274                               (if (> size 4)
2275                                   (list (lambda (f g ta t d)
2276                                           (append
2277                                            (i386:accu+n 4)
2278                                            (i386:base+n 4)
2279                                            (i386:base-address->accu-address))))
2280                                   '())
2281                               (if (> size 8)
2282                                   (list (lambda (f g ta t d)
2283                                           (append
2284                                            (i386:accu+n 4)
2285                                            (i386:base+n 4)
2286                                            (i386:base-address->accu-address))))
2287                                   '())))
2288                          ((ident-add info) index 1)))))
2289
2290         ;; DECL
2291         ;;
2292         ;; struct f = {...};
2293         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2294          (let* ((type (decl->type type))
2295                 ;;(foo (stderr "1DECL: ~s\n" type))
2296                 (fields (type->description info type))
2297                 (size (type->size info type))
2298                 (field-size 4))  ;; FIXME:4, not fixed
2299            ;;(stderr  "7TYPE: ~s\n" type)
2300            (if (.function info)
2301                (let* ((globals (append globals (filter-map initzer->global initzers)))
2302                       (locals (let loop ((fields (cdr fields)) (locals locals))
2303                                 (if (null? fields) locals
2304                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2305                       (locals (add-local locals name type -1))
2306                       (info (clone info #:locals locals #:globals globals))
2307                       (empty (clone info #:text '())))
2308                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2309                    (if (null? fields) info
2310                        (let ((offset (* field-size (car fields)))
2311                              (initzer (car initzers)))
2312                          (loop (cdr fields) (cdr initzers)
2313                                (clone info #:text
2314                                       (append
2315                                        (.text info)
2316                                        ((ident->accu info) name)
2317                                        (list (lambda (f g ta t d)
2318                                                (append
2319                                                 (i386:accu->base))))
2320                                        (.text ((expr->accu empty) initzer))
2321                                        (list (lambda (f g ta t d)
2322                                                (i386:accu->base-address+n offset))))))))))
2323                (let* ((globals (append globals (filter-map initzer->global initzers)))
2324                       (global (make-global name type -1 (string->list (make-string size #\nul))))
2325                       (globals (append globals (list global)))
2326                       (here (data-offset name globals))
2327                       (info (clone info #:globals globals))
2328                       (field-size 4))
2329                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2330                    (if (null? fields) info
2331                        (let ((offset (* field-size (car fields)))
2332                              (initzer (car initzers)))
2333                          (loop (cdr fields) (cdr initzers)
2334                                (clone info #:init
2335                                       (append
2336                                        (.init info)
2337                                        (list (lambda (functions globals ta t d data)
2338                                                (append
2339                                                 (list-head data (+ here offset))
2340                                                 (initzer->data info functions globals ta t d (car initzers))
2341                                                 (list-tail data (+ here offset field-size)))))))))))))))
2342
2343
2344         ;;char cc = g_cells[c].cdr;  ==> generic?
2345         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2346          (let ((type (decl->type type)))
2347            (if (.function info)
2348                (let* ((locals (add-local locals name type 0))
2349                       (info (clone info #:locals locals)))
2350                  (clone info #:text
2351                         (append (.text ((expr->accu info) initzer))
2352                                 ((accu->ident info) name))))
2353                (let* ((globals (append globals (list (ident->global name type 1 0))))
2354                       (here (data-offset name globals)))
2355                  (clone info
2356                         #:globals globals
2357                         #:init (append (.init info)
2358                                        (list (lambda (functions globals ta t d data)
2359                                                (append
2360                                                 (list-head data here)
2361                                                 (initzer->data info functions globals ta t d initzer)
2362                                                 (list-tail data (+ here 4)))))))))))
2363
2364
2365         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2366          info)
2367
2368         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
2369          info)
2370
2371         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2372          (let ((types (.types info)))
2373            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
2374
2375         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2376          (format (current-error-port) "SKIP: typedef=~s\n" o)
2377          info)
2378
2379         ((decl (@ ,at))
2380          (format (current-error-port) "SKIP: at=~s\n" o)
2381          info)
2382
2383         ((decl . _)
2384          (format (current-error-port) "SKIP: decl statement=~s\n" o)
2385          barf
2386          info)
2387
2388         (_
2389          (format (current-error-port) "SKIP: statement=~s\n" o)
2390          barf
2391          info)))))
2392
2393 (define (initzer->data info functions globals ta t d o)
2394   (pmatch o
2395     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2396     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2397     ((initzer (ref-to (p-expr (ident ,name))))
2398      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2399      (int->bv32 (+ ta (function-offset name functions))))
2400     ((initzer (p-expr (ident ,name)))
2401      (let ((value (assoc-ref (.constants info) name)))
2402        (int->bv32 value)))
2403     ((initzer (p-expr (string ,string)))
2404      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2405     (_ (stderr "initzer->data:SKIP: ~s\n" o)
2406        barf
2407      (int->bv32 0))))
2408
2409 (define (info->exe info)
2410   (display "dumping elf\n" (current-error-port))
2411   (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2412
2413 (define (.formals o)
2414   (pmatch o
2415     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2416     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2417     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2418        barf)))
2419
2420 (define (formal->text n)
2421   (lambda (o i)
2422     ;;(i386:formal i n)
2423     '()
2424     ))
2425
2426 (define (formals->text o)
2427   (pmatch o
2428     ((param-list . ,formals)
2429      (let ((n (length formals)))
2430        (list (lambda (f g ta t d)
2431                (append
2432                 (i386:function-preamble)
2433                 (append-map (formal->text n) formals (iota n))
2434                 (i386:function-locals))))))
2435     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2436        barf)))
2437
2438 (define (formal:ptr o)
2439   (pmatch o
2440     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2441      1)
2442     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2443      0)
2444     (_
2445      (stderr "formal:ptr[~a] => 0\n" o)
2446      0)))
2447
2448 (define (formals->locals o)
2449   (pmatch o
2450     ((param-list . ,formals)
2451      (let ((n (length formals)))
2452        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2453     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2454        barf)))
2455
2456 (define (function->info info)
2457   (lambda (o)
2458     ;;(stderr "function->info o=~s\n" o)
2459     ;;(stderr "formals=~s\n" (.formals o))
2460     (let* ((name (.name o))
2461            (formals (.formals o))
2462            (text (formals->text formals))
2463            (locals (formals->locals formals)))
2464       (format (current-error-port) "compiling ~s\n" name)
2465       ;;(stderr "locals=~s\n" locals)
2466       (let loop ((statements (.statements o))
2467                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2468         (if (null? statements) (clone info
2469                                       #:function #f
2470                                       #:functions (append (.functions info) (list (cons name (.text info)))))
2471             (let* ((statement (car statements)))
2472               (loop (cdr statements)
2473                     ((ast->info info) (car statements)))))))))
2474
2475 (define (ast-list->info info)
2476   (lambda (elements)
2477     (let loop ((elements elements) (info info))
2478       (if (null? elements) info
2479           (loop (cdr elements) ((ast->info info) (car elements)))))))
2480
2481 (define (compile)
2482   (stderr "COMPILE\n")
2483   (let* ((ast (mescc))
2484          (info (make <info>
2485                  #:functions i386:libc
2486                  #:types i386:type-alist))
2487          (ast (append libc ast))
2488          (info ((ast->info info) ast))
2489          (info ((ast->info info) _start)))
2490     (info->exe info)))