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