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