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