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