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