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