1f57ed7fa2d23b97ec787ddefa2abd52c192c2b0
[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 (cond-expand
29  (guile-2
30   (set-port-encoding! (current-output-port) "ISO-8859-1"))
31  (guile)
32  (mes
33   (mes-use-module (nyacc lang c99 parser))
34   (mes-use-module (mes elf-util))
35   (mes-use-module (mes pmatch))
36   (mes-use-module (mes elf))
37   (mes-use-module (mes libc-i386))
38   (mes-use-module (mes optargs))))
39
40 (define (logf port string . rest)
41   (apply format (cons* port string rest))
42   (force-output port)
43   #t)
44
45 (define (stderr string . rest)
46   (apply logf (cons* (current-error-port) string rest)))
47
48 (define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
49
50 (define (mescc)
51   (parse-c99
52    #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
53    #:cpp-defs '(
54                 ("__GNUC__" . "0")
55                 ("__NYACC__" . "1")
56                 ("VERSION" . "0.4")
57                 ("PREFIX" . "\"\"")
58                 )
59    #:xdef? gnuc-xdef?
60    #:mode 'code
61    ))
62
63 (define (write-any x)
64   (write-char (cond ((char? x) x)
65                     ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a\n" x) (integer->char #xaa))
66                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
67                     ((procedure? x)
68                      (stderr "write-any: proc: ~a\n" x)
69                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
70                      barf)
71                     (else (stderr "write-any: ~a\n" x) barf))))
72
73 (define (ast:function? o)
74   (and (pair? o) (eq? (car o) 'fctn-defn)))
75
76 (define (.name o)
77   (pmatch o
78     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
79     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
80     ((param-decl _ (param-declr (ident ,name))) name)
81     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
82     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
83     (_
84      (format (current-error-port) "SKIP .name =~a\n" o))))
85
86 (define (.statements o)
87   (pmatch o
88     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
89     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
90
91 (define <info> '<info>)
92 (define <types> '<types>)
93 (define <constants> '<constants>)
94 (define <functions> '<functions>)
95 (define <globals> '<globals>)
96 (define <locals> '<locals>)
97 (define <function> '<function>)
98 (define <text> '<text>)
99
100 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (function #f) (text '()))
101   (pmatch o
102     (<info> (list <info>
103                   (cons <types> types)
104                   (cons <constants> constants)
105                   (cons <functions> functions)
106                   (cons <globals> globals)
107                   (cons <locals> locals)
108                   (cons <function> function)
109                   (cons <text> text)))))
110
111 (define (.types o)
112   (pmatch o
113     ((<info> . ,alist) (assq-ref alist <types>))))
114
115 (define (.constants o)
116   (pmatch o
117     ((<info> . ,alist) (assq-ref alist <constants>))))
118
119 (define (.functions o)
120   (pmatch o
121     ((<info> . ,alist) (assq-ref alist <functions>))))
122
123 (define (.globals o)
124   (pmatch o
125     ((<info> . ,alist) (assq-ref alist <globals>))))
126
127 (define (.locals o)
128   (pmatch o
129     ((<info> . ,alist) (assq-ref alist <locals>))))
130
131 (define (.function o)
132   (pmatch o
133     ((<info> . ,alist) (assq-ref alist <function>))))
134
135 (define (.text o)
136   (pmatch o
137     ((<info> . ,alist) (assq-ref alist <text>))))
138
139 (define (info? o)
140   (and (pair? o) (eq? (car o) <info>)))
141
142 (define (clone o . rest)
143   (cond ((info? o)
144          (let ((types (.types o))
145                (constants (.constants o))
146                (functions (.functions o))
147                (globals (.globals o))
148                (locals (.locals o))
149                (function (.function o))
150                (text (.text o)))
151            (let-keywords rest
152                          #f
153                          ((types types)
154                           (constants constants)
155                           (functions functions)
156                           (globals globals)
157                           (locals locals)
158                           (function function)
159                           (text text))
160                          (make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text))))))
161
162 (define (push-global-ref globals)
163   (lambda (o)
164     (lambda (f g t d)
165       (i386:push-global-ref (+ (data-offset o g) d)))))
166
167 (define (push-global globals)
168   (lambda (o)
169     (lambda (f g t d)
170       (i386:push-global (+ (data-offset o g) d)))))
171
172 (define push-global-de-ref push-global)
173
174 (define (push-ident globals locals)
175   (lambda (o)
176     (let ((local (assoc-ref locals o)))
177       (if local (i386:push-local local)
178           ((push-global globals) o))))) ;; FIXME: char*/int
179
180 (define (push-ident-ref globals locals)
181   (lambda (o)
182     (let ((local (assoc-ref locals o)))
183       (if local (i386:push-local-ref local)
184           ((push-global-ref globals) o)))))
185
186 (define (push-ident-de-ref globals locals)
187   (lambda (o)
188     (let ((local (assoc-ref locals o)))
189       (if local (i386:push-local-de-ref local)
190           ((push-global-de-ref globals) o)))))
191
192 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
193   (lambda (o)
194     (pmatch o
195       ((p-expr (fixed ,value)) (cstring->number value))
196       ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
197       ((p-expr (string ,string)) ((push-global-ref (.globals info)) string))
198       ((p-expr (ident ,name))
199        ((push-ident (.globals info) (.locals info)) name))
200
201       ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
202        (let ((value (cstring->number value))
203              (size 4)) ;; FIXME: type: int
204          (append
205           ((ident->base info) name)
206           (list
207            (lambda (f g t d)
208              (append
209               (i386:value->accu (* size value)) ;; FIXME: type: int
210               (i386:base-mem->accu)             ;; FIXME: type: int
211               (i386:push-accu)                  ;; hmm
212               ))))))
213
214       ((de-ref (p-expr (ident ,name)))
215        (lambda (f g t d)
216          ((push-ident-de-ref (.globals info) (.locals info)) name)))
217
218       ((ref-to (p-expr (ident ,name)))
219        (lambda (f g t d)
220          ((push-ident-ref (.globals info) (.locals info)) name)))
221
222       ;; f (car (x))
223       ((fctn-call . ,call)
224        (let ((info ((ast->info info) o)))
225          (append (.text info)
226                  (list
227                   (lambda (f g t d)
228                     (i386:push-accu))))))
229
230       ;; f (CAR (x))
231       ((d-sel . ,d-sel)
232        (let* ((empty (clone info #:text '()))
233               (expr ((expr->accu empty) `(d-sel ,@d-sel))))
234          (append (.text expr)
235                  (list (lambda (f g t d)
236                          (i386:push-accu))))))
237
238       ;; f (0 + x)
239       ;;; aargh
240       ;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
241
242       ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
243                         (abs-declr (pointer)))
244              ,cast)
245        ((expr->arg info) cast))
246       (_
247        (format (current-error-port) "SKIP expr->arg=~s\n" o)     
248        0))))
249
250 (define (ident->accu info)
251   (lambda (o)
252     (let ((local (assoc-ref (.locals info) o)))
253       (if local
254           (list (lambda (f g t d)
255                   (if (equal? o "c1")
256                       (i386:byte-local->accu local) ;; FIXME
257                       (i386:local->accu local))))
258           (list (lambda (f g t d)
259                   (i386:global->accu (+ (data-offset o g) d))))))))
260
261 (define (accu->ident info)
262   (lambda (o)
263     (let ((local (assoc-ref (.locals info) o)))
264       (if local
265           (list (lambda (f g t d)
266                   (i386:accu->local local)))
267           (list (lambda (f g t d)
268                   (i386:accu->global (+ (data-offset o g) d))))))))
269
270 (define (base->ident-ref info)
271   (lambda (o)
272     (let ((local (assoc-ref (.locals info) o)))
273       (if local
274           (list (lambda (f g t d)
275                   (append
276                    (i386:local->accu local)
277                    (i386:byte-base->accu-ref))))
278           TODO:base->ident-ref-global))))
279
280 (define (value->ident info)
281   (lambda (o value)
282     (let ((local (assoc-ref (.locals info) o)))
283       (if local
284           (list (lambda (f g t d)
285                   (i386:value->local local value)))
286           (list (lambda (f g t d)
287                   (i386:value->global (+ (data-offset o g) d) value)))))))
288
289 (define (ident-address->accu info)
290   (lambda (o)
291     (let ((local (assoc-ref (.locals info) o)))
292       (if local
293           (list (lambda (f g t d)
294                   (i386:local-address->accu local)))
295           (list (lambda (f g t d)
296                   (i386:global->accu (+ (data-offset o g) d))))))))
297
298 (define (ident->base info)
299   (lambda (o)
300     (let ((local (assoc-ref (.locals info) o)))
301       (if local
302           (list (lambda (f g t d)
303                   (i386:local->base local)))
304           (list (lambda (f g t d)
305                   (i386:global->base (+ (data-offset o g) d))))))))
306
307 (define (ident-ref->base info)
308   (lambda (o)
309     (let ((local (assoc-ref (.locals info) o)))
310       (if local
311           (list (lambda (f g t d)
312                   (i386:local-ref->base local)))
313           TODO:ident-ref->base))))
314
315 (define (expr->accu info)
316   (lambda (o)
317     (pmatch o
318       ((p-expr (fixed ,value)) (cstring->number value))
319       ((p-expr (ident ,name)) (car ((ident->accu info) name)))
320       ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
321       ((not (fctn-call . _)) ((ast->info info) o))
322       ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
323       ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
324
325       ;; g_cells[10].type
326       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
327        (let* ((struct-type "scm") ;; FIXME
328               (struct (assoc-ref (.types info) struct-type))
329               (size (length struct))
330               (field-size 4) ;; FIXME:4, not fixed
331               (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
332               (index (cstring->number index))
333               (text (.text info)))
334          (clone info #:text
335                 (append text
336                         (list (lambda (f g t d)
337                                 (append
338                                  (i386:value->base index)
339                                  (i386:base->accu)
340                                  (if (> size 1) (i386:accu+accu) '())
341                                  (if (= size 3) (i386:accu+base) '())
342                                  (i386:accu-shl 2))))
343                         ((ident->base info) array)
344                         (list (lambda (f g t d)
345                                 (i386:accu+base)))))))
346
347       ;; g_cells[x].type
348       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
349        (let* ((struct-type "scm") ;; FIXME
350               (struct (assoc-ref (.types info) struct-type))
351               (size (length struct))
352               (field-size 4) ;; FIXME:4, not fixed
353               (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
354               (text (.text info)))
355          (clone info #:text
356                 (append text
357                         ((ident->base info) index)
358                         (list (lambda (f g t d)
359                                 (append
360                                  (i386:base->accu)
361                                  (if (> size 1) (i386:accu+accu) '())
362                                  (if (= size 3) (i386:accu+base) '())
363                                  (i386:accu-shl 2))))
364                         ((ident->base info) array)
365                         (list (lambda (f g t d)
366                                 (i386:base-mem+n->accu offset)
367                                 ;;(i386:accu+base)
368                                 ))))))
369
370       (_
371        (format (current-error-port) "SKIP expr->accu=~s\n" o)
372        info)
373       )))
374
375 (define (expr->Xaccu info)
376   (lambda (o)
377     (pmatch o
378       ;; g_cells[10].type
379       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
380        (let* ((struct-type "scm") ;; FIXME
381               (struct (assoc-ref (.types info) struct-type))
382               (size (length struct))
383               (field-size 4) ;; FIXME:4, not fixed
384               (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
385               (index (cstring->number index))
386               (text (.text info)))
387          (clone info #:text
388                 (append text
389                         (list (lambda (f g t d)
390                                 (append
391                                  (i386:value->base index)
392                                  (i386:base->accu)
393                                  (if (> size 1) (i386:accu+accu) '())
394                                  (if (= size 3) (i386:accu+base) '())
395                                  (i386:accu-shl 2))))
396                         ((ident->base info) array)
397                         (list (lambda (f g t d)
398                                 (i386:accu+base)))))))
399
400       ;; g_cells[x].type
401       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
402        (let* ((struct-type "scm") ;; FIXME
403               (struct (assoc-ref (.types info) struct-type))
404               (size (length struct))
405               (field-size 4) ;; FIXME:4, not fixed
406               (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
407               (text (.text info)))
408          (clone info #:text
409                 (append text
410                         ((ident->base info) index)
411                         (list (lambda (f g t d)
412                                 (append
413                                  (i386:base->accu)
414                                  (if (> size 1) (i386:accu+accu) '())
415                                  (if (= size 3) (i386:accu+base) '())
416                                  (i386:accu-shl 2))))
417                         ((ident->base info) array)
418                         (list (lambda (f g t d)
419                                 (i386:accu+base)))))))
420
421       (_
422        (format (current-error-port) "SKIP expr->Xaccu=~s\n" o)
423        info)
424       )))
425
426 (define (string->global string)
427   (cons string (append (string->list string) (list #\nul))))
428
429 (define (ident->global name value)
430   (cons name (int->bv32 value)))
431
432 (define (ident->constant name value)
433   (cons name value))
434
435 (define (ident->type name value)
436   (cons name value))
437
438 (define (expr->global o)
439   (pmatch o
440     ((p-expr (string ,string)) (string->global string))
441     (_ #f)))
442
443 (define (dec->hex o)
444   (number->string o 16))
445
446 (define (byte->hex o)
447   (string->number (string-drop o 2) 16))
448
449 (define (asm->hex o)
450   (let ((prefix ".byte "))
451     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
452         (let ((s (string-drop o (string-length prefix))))
453           (map byte->hex (string-split s #\space))))))
454
455 (define (case->jump-info info)
456   (define (jump n)
457     (list (lambda (f g t d) (i386:Xjump n))))
458   (define (jump-nz n)
459     (list (lambda (f g t d) (i386:Xjump-nz n))))
460   (define (statement->info info body-length)
461     (lambda (o)
462       (pmatch o
463         ((break) (clone info #:text (append (.text info) (jump body-length)
464 )))
465         (_
466          ((ast->info info) o)))))
467   (lambda (o)
468     (pmatch o
469       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
470        (lambda (body-length)
471          (let* ((value (assoc-ref (.constants info) constant))
472                 (text-length (length (.text info)))
473                 (clause-info (let loop ((elements elements) (info info))
474                                (if (null? elements) info
475                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
476                 (clause-text (list-tail (.text clause-info) text-length))
477                 (clause-length (length (text->list clause-text))))
478            (clone info #:text (append
479                                (.text info)
480                                (list (lambda (f g t d) (i386:accu-cmp-value value)))
481                                (jump-nz clause-length)
482                                clause-text)
483                   #:globals (.globals clause-info)))))
484
485       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
486        (lambda (body-length)
487          (let* ((value (cstring->number value))
488                 (text-length (length (.text info)))
489                 (clause-info (let loop ((elements elements) (info info))
490                                (if (null? elements) info
491                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
492                 (clause-text (list-tail (.text clause-info) text-length))
493                 (clause-length (length (text->list clause-text))))
494            (clone info #:text (append
495                                (.text info)
496                                (list (lambda (f g t d) (i386:accu-cmp-value value)))
497                                (jump-nz clause-length)
498                                clause-text)
499                   #:globals (.globals clause-info)))))
500
501       ((default (compd-stmt (block-item-list . ,elements)))
502        (lambda (body-length)
503          (let ((text-length (length (.text info))))
504           (let loop ((elements elements) (info info))
505             (if (null? elements) info
506                 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
507       (_ (stderr "no case match: ~a\n" o) barf)
508       )))
509
510 (define (test->jump->info info)
511   (define (jump type)
512     (lambda (o)
513       (let* ((text (.text info))
514              (info (clone info #:text '()))
515              (info ((ast->info info) o))
516              (jump-text (lambda (body-length)
517                           (list (lambda (f g t d) (type body-length))))))
518        (lambda (body-length)
519          (clone info #:text
520                 (append text
521                         (.text info)
522                         (jump-text body-length)))))))
523   (lambda (o)
524     (pmatch o
525       ((lt ,a ,b) ((jump i386:jump-nc) o))
526       ((gt ,a ,b) ((jump i386:jump-nc) o))
527       ((ne ,a ,b) ((jump i386:jump-nz) o))
528       ((eq ,a ,b) ((jump i386:jump-nz) o))
529       ((not _) ((jump i386:jump-z) o))
530       ((and ,a ,b)
531        (let* ((text (.text info))
532               (info (clone info #:text '()))
533
534               (a-jump ((test->jump->info info) a))
535               (a-text (.text (a-jump 0)))
536               (a-length (length (text->list a-text)))
537
538               (b-jump ((test->jump->info info) b))
539               (b-text (.text (b-jump 0)))
540               (b-length (length (text->list b-text))))
541
542          (lambda (body-length)
543            (clone info #:text
544                   (append text
545                           (.text (a-jump (+ b-length body-length)))
546                           (.text (b-jump body-length)))))))
547       ((array-ref . _) ((jump i386:jump-byte-z) o))
548       ((de-ref _) ((jump i386:jump-byte-z) o))
549       (_ ((jump i386:jump-z) o)))))
550
551 (define (cstring->number s)
552   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
553         ((string-prefix? "0" s) (string->number s 8))
554         (else (string->number s))))
555
556 (define (struct-field o)
557   (pmatch o
558     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
559                 (comp-declr-list (comp-declr (ident ,name))))
560      (cons type name))
561     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
562      (cons type name))
563     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
564      (cons type name))
565     (_ (stderr "struct-field: no match: ~a" o) barf)))
566
567 (define (ast->info info)
568   (lambda (o)
569     (let ((globals (.globals info))
570           (locals (.locals info))
571           (text (.text info)))
572       (define (add-local name)
573         (let ((locals (acons name (1+ (length (filter positive? (map cdr locals)))) locals)))
574           locals))
575
576       ;;(stderr "\nS=~a\n" o)
577       ;; (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)))
578       ;; (stderr "  text=~a\n" text)
579       ;; (stderr "   info=~a\n" info)
580       ;; (stderr "   globals=~a\n" globals)
581       (pmatch o
582         (((trans-unit . _) . _) ((ast-list->info info) o))
583         ((trans-unit . ,elements) ((ast-list->info info) elements))
584         ((fctn-defn . _) ((function->info info) o))
585         ((comment . _) info)
586         ((cpp-stmt (define (name ,name) (repl ,value)))
587          (stderr "SKIP: #define ~s ~s\n" name value)
588          info)
589
590         ;; ;
591         ((expr-stmt) info)
592
593         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
594         
595         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
596          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
597                                    (clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
598              (let* ((globals (append globals (filter-map expr->global expr-list)))
599                     (info (clone info #:globals globals))
600                     (args (map (expr->arg info) expr-list)))
601                (clone info #:text
602                       (append text (list (lambda (f g t d)
603                                            (apply i386:call (cons* f g t d
604                                                                    (+ t (function-offset name f)) args)))))
605                       #:globals globals))))
606
607         ((if ,test ,body)
608          (let* ((text-length (length text))
609
610                 (test-jump->info ((test->jump->info info) test))
611                 (test+jump-info (test-jump->info 0))
612                 (test-length (length (.text test+jump-info)))
613
614                 (body-info ((ast->info test+jump-info) body))
615                 (text-body-info (.text body-info))
616                 (body-text (list-tail text-body-info test-length))
617                 (body-length (length (text->list body-text)))
618
619                 (text+test-text (.text (test-jump->info body-length)))
620                 (test-text (list-tail text+test-text text-length)))
621
622            (clone info #:text
623                   (append text
624                           test-text
625                           body-text)
626                   #:globals (.globals body-info))))
627
628         ((expr-stmt (cond-expr ,test ,then ,else))
629          (let* ((text-length (length text))
630
631                 (test-jump->info ((test->jump->info info) test))
632                 (test+jump-info (test-jump->info 0))
633                 (test-length (length (.text test+jump-info)))
634
635                 (then-info ((ast->info test+jump-info) then))
636                 (text-then-info (.text then-info))
637                 (then-text (list-tail text-then-info test-length))
638                 (then-length (length (text->list then-text)))
639
640                 (jump-text (list (lambda (f g t d) (i386:jump 0))))
641                 (jump-length (length (text->list jump-text)))
642                 (test+then+jump-info
643                  (clone then-info
644                         #:text (append (.text then-info) jump-text)))
645
646                 (else-info ((ast->info test+then+jump-info) else))
647                 (text-else-info (.text else-info))
648                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
649                 (else-length (length (text->list else-text)))
650
651                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
652                 (test-text (list-tail text+test-text text-length))
653                 (jump-text (list (lambda (f g t d) (i386:jump else-length)))))
654
655            (clone info #:text
656                   (append text
657                           test-text
658                           then-text
659                           jump-text
660                           else-text)
661                   #:globals (.globals else-info))))
662
663         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
664          (let* ((accu ((expr->accu info) expr))
665                 (expr (if (info? accu) accu ;; AAARGH
666                           (clone info #:text
667                                  (append text (list accu)))))
668                 (empty (clone info #:text '()))
669                 (case-infos (map (case->jump-info empty) cases))
670                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
671                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
672                               (if (null? cases) info
673                                   (let ((c-j ((case->jump-info info) (car cases))))
674                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
675            cases-info))
676
677         ((for ,init ,test ,step ,body)
678          (let* ((info (clone info #:text '()))
679
680                 (info ((ast->info info) init))
681
682                 (init-text (.text info))
683                 (init-locals (.locals info))
684                 (info (clone info #:text '()))
685
686                 (body-info ((ast->info info) body))
687                 (body-text (.text body-info))
688                 (body-length (length (text->list body-text)))
689
690                 (step-info ((ast->info info) `(expr-stmt ,step)))
691                 (step-text (.text step-info))
692                 (step-length (length (text->list step-text)))
693
694                 (test-jump->info ((test->jump->info info) test))
695                 (test+jump-info (test-jump->info 0))
696                 (test-length (length (text->list (.text test+jump-info))))
697
698                 (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length step-length))))) ;; FIXME: 2
699
700                 (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length step-length test-length))))))
701                 (jump-length (length (text->list jump-text)))
702
703                 (test-text (.text (test-jump->info jump-length))))
704
705            (clone info #:text
706                   (append text
707                           init-text
708                           skip-body-text
709                           body-text
710                           step-text
711                           test-text
712                           jump-text)
713                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
714                   #:locals locals)))
715
716         ((while ,test ,body)
717          (let* ((info (clone info #:text '()))
718                 (body-info ((ast->info info) body))
719                 (body-text (.text body-info))
720                 (body-length (length (text->list body-text)))
721
722                 (test-jump->info ((test->jump->info info) test))
723                 (test+jump-info (test-jump->info 0))
724                 (test-length (length (text->list (.text test+jump-info))))
725
726
727                 (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length))))) ;; FIXME: 2
728
729                 (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length test-length))))))
730                 (jump-length (length (text->list jump-text)))
731
732                 (test-text (.text (test-jump->info jump-length))))
733
734            (clone info #:text
735                   (append text
736                           skip-body-text
737                           body-text
738                           test-text
739                           jump-text)
740                   #:globals (.globals body-info))))
741
742         ((labeled-stmt (ident ,label) ,statement)
743          (let ((info (clone info #:text (append text (list label)))))
744            ((ast->info info) statement)))
745
746         ((goto (ident ,label))
747          (let ((offset (length (text->list text))))
748            (clone info #:text
749                   (append text
750                           (list (lambda (f g t d)
751                                   (i386:jump (- (label-offset (.function info) label f) offset))))))))
752
753         ((p-expr (ident ,name))
754          (clone info #:text
755                 (append text
756                         ((ident->accu info) name)
757                         (list (lambda (f g t d)
758                                 (append
759                                  (i386:accu-zero?)))))))
760
761         ((p-expr (fixed ,value))
762          (let ((value (cstring->number value)))
763           (clone info #:text
764                  (append text
765                          (list (lambda (f g t d)
766                                  (append
767                                   (i386:value->accu value)
768                                   (i386:accu-zero?))))))))
769
770         ((de-ref (p-expr (ident ,name)))
771          (clone info #:text
772                 (append text
773                         ((ident->accu info) name)
774                         (list (lambda (f g t d)
775                                 (append
776                                  (i386:byte-mem->accu)))))))
777
778         ((fctn-call . ,call)
779          (let ((info ((ast->info info) `(expr-stmt ,o))))
780            (clone info #:text
781                   (append (.text info)
782                           (list (lambda (f g t d)
783                                   (i386:accu-zero?)))))))
784
785         ;; FIXME
786         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
787         ((post-inc (p-expr (ident ,name)))
788          (clone info #:text
789                 (append text
790                         ((ident->accu info) name)
791                         (list (lambda (f g t d)
792                                 (append
793                                  (i386:local-add (assoc-ref locals name) 1)
794                                  (i386:accu-zero?)))))))
795         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
796         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
797         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
798         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
799
800         ;; i++
801         ((expr-stmt (post-inc (p-expr (ident ,name))))
802          (clone info #:text
803                 (append text (list (lambda (f g t d)
804                                      (i386:local-add (assoc-ref locals name) 1))))))
805
806         ;; ++i
807         ((expr-stmt (pre-inc (p-expr (ident ,name))))
808          (clone info #:text
809                 (append text (list (lambda (f g t d)
810                                      (append
811                                       (i386:local-add (assoc-ref locals name) 1)
812                                       (i386:local->accu (assoc-ref locals name))
813                                       (i386:accu-zero?)))))))
814
815         ;; i--
816         ((expr-stmt (post-dec (p-expr (ident ,name))))
817          (clone info #:text
818                 (append text
819                         ((ident->accu info) name)
820                         (list (lambda (f g t d)
821                                 (append
822                                  (i386:local-add (assoc-ref locals name) -1)
823                                  (i386:accu-zero?)))))))
824
825         ;; --i
826         ((expr-stmt (pre-dec (p-expr (ident ,name))))
827          (clone info #:text
828                 (append text (list (lambda (f g t d)
829                                      (append
830                                       (i386:local-add (assoc-ref locals name) -1)
831                                       (i386:local->accu (assoc-ref locals name))
832                                       (i386:accu-zero?)))))))
833
834         ((not ,expr)
835          (let* ((test-info ((ast->info info) expr)))
836            (clone info #:text
837                   (append (.text test-info)
838                           (list (lambda (f g t d)
839                                   (append
840                                    (i386:accu-not)
841                                    (i386:accu-zero?)))))
842                   #:globals (.globals test-info))))
843
844         ((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
845          (let ((b (cstring->number b)))
846            (clone info #:text
847                   (append text
848                           ((ident->base info) a)
849                           (list (lambda (f g t d)
850                                   (append
851                                    (i386:value->accu b)
852                                    (i386:sub-base))))))))
853
854         ((eq (p-expr (ident ,a)) (p-expr (char ,b)))
855          (let ((b (char->integer (car (string->list b)))))
856            (clone info #:text
857                   (append text
858                           ((ident->base info) a)
859                           (list (lambda (f g t d)
860                                   (append
861                                    (i386:value->accu b)
862                                    (i386:sub-base))))))))
863
864         ((eq (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
865          (let ((b (- (cstring->number b))))
866            (clone info #:text
867                   (append text
868                           ((ident->base info) a)
869                           (list (lambda (f g t d)
870                                   (append 
871                                    (i386:value->accu b)
872                                    (i386:sub-base))))))))
873
874         ((eq (fctn-call . ,call) (p-expr (fixed ,b)))
875          (let ((b (cstring->number b))
876                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
877            (clone info #:text
878                   (append text
879                           (.text info)
880                           (list (lambda (f g t d)
881                                   (append
882                                    (i386:value->base b)
883                                    (i386:sub-base))))))))
884
885         ((eq (fctn-call . ,call) (p-expr (char ,b)))
886          (let ((b (char->integer (car (string->list b))))
887                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
888            (clone info #:text
889                   (append text
890                           (.text info)
891                           (list (lambda (f g t d)
892                                   (append
893                                    (i386:value->base b)
894                                    (i386:sub-base))))))))
895
896         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
897          info)
898
899         ((eq (fctn-call . ,call) (p-expr (ident ,b)))
900          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
901            (clone info #:text
902                   (append text
903                           (.text info)
904                           ((ident->base info) b)
905                           (list (lambda (f g t d)
906                                   (append
907                                    (i386:sub-base))))))))
908
909         ((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
910            (clone info #:text
911                   (append text
912                           ((ident->accu info) a)
913                           (list (lambda (f g t d)
914                                   (append
915                                    (i386:byte-mem->base)
916                                    (i386:local->accu (assoc-ref locals b))
917                                    (i386:byte-mem->accu)
918                                    (i386:byte-test-base)))))))
919
920         ((eq (de-ref (p-expr (ident ,a))) (p-expr (char ,b)))
921          (let ((b (char->integer (car (string->list b)))))
922            (clone info #:text
923                   (append text
924                           ((ident->accu info) a)
925                           (list (lambda (f g t d)
926                                   (append
927                                    (i386:byte-mem->base)
928                                    (i386:value->accu b)
929                                    (i386:byte-test-base))))))))
930
931         ((eq (d-sel (ident ,field) . ,d-sel) (p-expr (fixed ,b)))
932          (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
933                 (b (cstring->number b))
934
935                 (struct-type "scm") ;; FIXME
936                 (struct (assoc-ref (.types info) struct-type))
937                 (size (length struct))
938                 (field-size 4) ;; FIXME:4, not fixed
939                 (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))))
940            (clone info #:text (append (.text expr)
941                                       (list (lambda (f g t d)
942                                               (append
943                                                (i386:mem+n->accu offset)
944                                                (i386:value->base b)
945                                                (i386:test-base))))))))
946
947         ((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
948          (let ((b (cstring->number b)))
949            (clone info #:text
950                   (append text
951                           ((ident->base info) a)
952                           (list (lambda (f g t d)
953                                   (append
954                                    (i386:value->accu b)
955                                    (i386:sub-base))))))))
956
957         ((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
958          (let ((b (- (cstring->number b))))
959            (clone info #:text
960                   (append text
961                           ((ident->base info) a)
962                           (list (lambda (f g t d)
963                                   (append 
964                                    (i386:value->accu b)
965                                    (i386:sub-base))))))))        
966
967         
968         ((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
969          (let ((b (cstring->number b)))
970            (clone info #:text
971                   (append text
972                           ((ident->base info) a)
973                           (list (lambda (f g t d)
974                                   (append 
975                                    (i386:value->accu b)
976                                    (i386:sub-base)
977                                    (i386:xor-zf))))))))
978
979         ((ne (p-expr (ident ,a)) (p-expr (char ,b)))
980          (let ((b (char->integer (car (string->list b)))))
981            (clone info #:text
982                   (append text
983                           ((ident->base info) a)
984                           (list (lambda (f g t d)
985                                   (append 
986                                    (i386:value->accu b)
987                                    (i386:sub-base)
988                                    (i386:xor-zf))))))))        
989
990         ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
991          (let ((b (- (cstring->number b))))
992            (clone info #:text
993                   (append text
994                           ((ident->base info) a)
995                           (list (lambda (f g t d)
996                                   (append
997                                    (i386:value->accu b)
998                                    (i386:sub-base)
999                                    (i386:xor-zf))))))))
1000
1001         ((ne (p-expr (ident ,a)) (p-expr (ident ,constant)))
1002          (let ((b (assoc-ref (.constants info) constant)))
1003            (clone info #:text
1004                   (append text
1005                           ((ident->base info) a)
1006                           (list (lambda (f g t d)
1007                                   (append
1008                                    (i386:value->accu b)
1009                                    (i386:sub-base)
1010                                    (i386:xor-zf))))))))
1011         
1012         ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
1013          (let ((b (cstring->number b))
1014                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1015            (clone info #:text
1016                   (append text
1017                           (.text info)
1018                           (list (lambda (f g t d)
1019                                   (append
1020                                    (i386:value->base b)
1021                                    (i386:sub-base)
1022                                    (i386:xor-zf))))))))
1023
1024         ((ne (fctn-call . ,call) (p-expr (ident ,b)))
1025          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1026            (clone info #:text
1027                   (append text
1028                           (.text info)
1029                           ((ident->base info) b)
1030                           (list (lambda (f g t d)
1031                                   (append
1032                                    (i386:sub-base)
1033                                    (i386:xor-zf))))))))
1034
1035         ((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1036            (clone info #:text
1037                   (append text
1038                           ((ident->accu info) a)
1039                           (list (lambda (f g t d)
1040                                   (append
1041                                    (i386:byte-mem->base)
1042                                    (i386:local->accu (assoc-ref locals b))
1043                                    (i386:byte-mem->accu)
1044                                    (i386:byte-test-base)
1045                                    (i386:xor-zf)))))))
1046
1047         ((ne (de-ref (p-expr (ident ,a))) (p-expr (char ,b)))
1048          (let ((b (char->integer (car (string->list b)))))
1049            (clone info #:text
1050                   (append text
1051                           ((ident->accu info) a)
1052                           (list (lambda (f g t d)
1053                                   (append
1054                                    (i386:byte-mem->base)
1055                                    (i386:value->accu b)
1056                                    (i386:byte-test-base)
1057                                    (i386:xor-zf))))))))
1058
1059         ;; CAR (x) != 1 // cell_nil
1060         ((ne (d-sel . ,d-sel) (p-expr (fixed ,b)))
1061          (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
1062                (b (cstring->number b)))
1063            (clone info #:text
1064                   (append text
1065                           (.text expr)
1066                           (list (lambda (f g t d)
1067                                   (append
1068                                    (i386:value->base b)
1069                                    (i386:sub-base)
1070                                    (i386:xor-zf))))))))
1071
1072         ;; CAR (x) != PAIR
1073         ((ne (d-sel . ,d-sel) (p-expr (ident ,constant)))
1074          (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
1075                (b (assoc-ref (.constants info) constant)))
1076            (clone info #:text
1077                   (append text
1078                           (.text expr)
1079                           (list (lambda (f g t d)
1080                                   (append
1081                                    (i386:value->base b)
1082                                    (i386:sub-base)
1083                                    (i386:xor-zf))))))))
1084
1085         ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
1086          (let ((b (cstring->number b)))
1087            (clone info #:text
1088                   (append text
1089                           ((ident->base info) a)
1090                           (list (lambda (f g t d)
1091                                   (append 
1092                                    (i386:value->accu b)
1093                                    (i386:base-sub))))))))
1094
1095         ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1096          (clone info #:text
1097                 (append text
1098                         (list (lambda (f g t d)
1099                                 (append
1100                                  ;;(and (stderr "006\n") '())
1101                                  (i386:local->accu (assoc-ref locals a))
1102                                  (i386:byte-mem->base)
1103                                  (i386:local->accu (assoc-ref locals b))
1104                                  (i386:byte-mem->accu)
1105                                  (i386:byte-sub-base)))))))
1106
1107         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
1108          (let ((value (cstring->number value)))
1109            (clone info #:text
1110                   (append text
1111                           ((ident->base info) name)
1112                           (list (lambda (f g t d)
1113                                        (append
1114                                         (i386:value->accu value)
1115                                         (i386:byte-base-mem->accu)))))))) ; FIXME: type: char
1116         
1117         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
1118          (clone info #:text
1119                 (append text
1120                         ((ident->base info) name)
1121                         ((ident->accu info) index)
1122                         (list (lambda (f g t d)
1123                                 (i386:byte-base-mem->accu)))))) ; FIXME: type: char
1124         
1125         ((return ,expr)
1126          (let ((accu ((expr->accu info) expr)))
1127            (if (info? accu)
1128                (clone accu #:text
1129                       (append (.text accu) (list (i386:ret (lambda _ '())))))
1130                (clone info #:text
1131                       (append text (list (i386:ret accu)))))))
1132
1133         ;; int i;
1134         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1135          (clone info #:locals (add-local name)))
1136
1137         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1138          (let* ((locals (add-local name))
1139                 (info (clone info #:locals locals)))
1140            (let ((value (cstring->number value)))
1141              (clone info #:text
1142                     (append text ((value->ident info) name value))))))
1143
1144         ;; int i = 0;
1145         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1146          (let* ((locals (add-local name))
1147                 (info (clone info #:locals locals))
1148                 (value (cstring->number value)))
1149            (clone info #:text
1150                   (append text
1151                           ((value->ident info) name value)))))
1152
1153         ;; char c = 'A';
1154         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1155          (let* ((locals (add-local name))
1156                 (info (clone info #:locals locals))
1157                 (value (char->integer (car (string->list value)))))
1158            (clone info #:text
1159                   (append text
1160                           ((value->ident info) name value)))))
1161
1162         ;; int i = -1;
1163         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1164          (let* ((locals (add-local name))
1165                 (info (clone info #:locals locals))
1166                 (value (- (cstring->number value))))
1167            (clone info #:text
1168                   (append text
1169                           ((value->ident info) name value)))))
1170
1171         ;; int i = argc;
1172         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1173          (let* ((locals (add-local name))
1174                 (info (clone info #:locals locals)))
1175            (clone info #:text
1176                   (append text
1177                           ((ident->accu info) local)
1178                           ((accu->ident info) name)))))
1179
1180         ;; char *p = "t.c";
1181         ;;(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"))))))
1182         ((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
1183          (let* ((locals (add-local name))
1184                 (globals (append globals (list (string->global value))))
1185                 (info (clone info #:locals locals #:globals globals)))
1186            (clone info #:text
1187                   (append text
1188                           (list (lambda (f g t d)
1189                                   (append
1190                                    (i386:global->accu (+ (data-offset value g) d)))))
1191                           ((accu->ident info) name)))))
1192         
1193         ;; char arena[20000];
1194         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1195          (let* ((globals (.globals info))
1196                 (count (cstring->number count))
1197                 (size 1) ;; FIXME
1198                 (array (list (ident->global name #xaaaaaaaa)))  ;;FIXME: deref?
1199                 (dummy (list (cons (string->list "dummy")
1200                                    (string->list (make-string (* count size) #\nul))))))
1201            (clone info #:globals (append globals array dummy))))
1202
1203         ;; struct scm* arena[200];
1204         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1205          (let* ((globals (.globals info))
1206                 (count (cstring->number count))
1207                 (size 12) ;; FIXME
1208                 (array (list (ident->global name #x58585858)))  ;;FIXME: deref?
1209                 (dummy (list (cons (string->list "dummy")
1210                                    (string->list (make-string (* count size) #\nul))))))
1211            (stderr "(* count size): ~a\n" (* count size))
1212            (clone info #:globals (append globals array dummy))))
1213
1214         ;;struct scm *g_cells = (struct scm*)arena;
1215         ((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)))))))
1216          (let* ((locals (add-local name))
1217                 (info (clone info #:locals locals)))
1218            (clone info #:text
1219                   (append text
1220                           ((ident->accu info) name)
1221                           ((accu->ident info) value))))) ;; FIXME: deref?
1222
1223         ;; SCM g_stack = 0;
1224         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1225          ((ast->info info) (list-head o (- (length o) 1))))
1226
1227         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1228          (if (.function info)
1229              (let* ((locals (add-local name))
1230                     (globals (append globals (list (string->global value))))
1231                     (info (clone info #:locals locals #:globals globals)))
1232                (clone info #:text
1233                       (append text
1234                               (list (lambda (f g t d)
1235                                       (append
1236                                        (i386:global->accu (+ (data-offset value g) d)))))
1237                               ((accu->ident info) name))))
1238              (let* ((value (length (globals->data globals)))
1239                     (globals (append globals (list (ident->global name value)))))
1240                (clone info #:globals globals))))
1241
1242         ;; SCM i = argc;
1243         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1244          (let* ((locals (add-local name))
1245                (info (clone info #:locals locals)))
1246            (clone info #:text
1247                   (append text
1248                           ((ident->accu info) local)
1249                           ((accu->ident info) name)))))
1250         
1251         ;; int i = f ();
1252         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1253          (let* ((locals (add-local name))
1254                 (info (clone info #:locals locals)))
1255            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1256              (clone info
1257                     #:text
1258                     (append (.text info)
1259                             ((accu->ident info) name))
1260                     #:locals locals))))
1261         
1262         ;; SCM x = car (e);
1263         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1264          (let* ((locals (add-local name))
1265                 (info (clone info #:locals locals)))
1266            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1267              (clone info
1268                     #:text
1269                     (append (.text info)
1270                             ((accu->ident info) name))))))
1271
1272         ;; char *p = (char*)g_cells;
1273         ((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)))))))
1274          (let* ((locals (add-local name))
1275                 (info (clone info #:locals locals)))
1276            (clone info #:text
1277                   (append text
1278                           ((ident->accu info) value)
1279                           ((accu->ident info) name)))))
1280
1281         ;; char *p = g_cells;
1282         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1283          (let* ((locals (add-local name))
1284                 (info (clone info #:locals locals)))
1285            (clone info #:text
1286                   (append text
1287                           ((ident->accu info) value)
1288                           ((accu->ident info) name)))))
1289
1290         ;; enum 
1291         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1292          (let ((type (ident->type name "enum"))
1293                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1294            (clone info #:types (append (.types info) (list type))
1295                   #:constants (append constants (.constants info)))))
1296
1297         ;; struct
1298         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1299          (let* ((type (ident->type name (map struct-field fields))))
1300            (clone info #:types (append (.types info) (list type)))))
1301         
1302         ;; i = 0;
1303         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
1304          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
1305          (let ((value (cstring->number value)))
1306            (clone info #:text (append text ((value->ident info) name value)))))
1307
1308         ;; i = 0; ...from for init FIXME
1309         ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
1310          (let ((value (cstring->number value)))
1311            (clone info #:text (append text ((value->ident info) name value)))))
1312
1313         ;; i = i + 48;
1314         ((expr-stmt (assn-expr (p-expr (ident ,a)) (op _) (add (p-expr (ident ,b)) (p-expr (fixed ,value)))))
1315          (let ((value (cstring->number value)))
1316            (clone info #:text
1317                   (append text
1318                           ((ident->base info) b)
1319                           (list (lambda (f g t d)
1320                                   (append
1321                                    (i386:value->accu value)
1322                                    (i386:accu+base))))
1323                           ((accu->ident info) a)))))
1324
1325         ;; c = 'A';
1326         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (char ,value))))
1327          (let ((value (char->integer (car (string->list value)))))
1328            (clone info #:text (append text ((value->ident info) name value)))))
1329
1330         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
1331          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1332            (clone info #:text (append (.text info) ((accu->ident info) name)))))
1333
1334         ;; p = g_cell;
1335         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (ident ,value))))
1336          (clone info #:text
1337                 (append text
1338                         ((ident->accu info) value)
1339                         ((accu->ident info) name))))
1340
1341         ;; *p = 0;
1342         ((expr-stmt (assn-expr (de-ref (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
1343          (let ((value (cstring->number value)))
1344            (clone info #:text (append text
1345                                       (list (lambda (f g t d)
1346                                               (i386:value->base 0)))
1347                                       ((base->ident-ref info) name)))))
1348
1349         ;; *p++ = c;
1350         ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op _) (p-expr (ident ,value))))
1351          ;; (stderr "VALUE: ~a\n" value)
1352          ;; (stderr "LOCALS: ~a\n" (.locals info))
1353          ;; (stderr " ==> ~a\n" (assoc-ref (.locals info) value))
1354          (clone info #:text
1355                 (append text
1356                         ;;((ident-ref->base info) value)
1357                         ((ident->base info) value)
1358                         ((base->ident-ref info) name)
1359                         (list (lambda (f g t d)
1360                                 (i386:local-add (assoc-ref locals name) 1))))))
1361
1362         ((d-sel . ,d-sel)
1363          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1364            expr))        
1365
1366         ;; i = CAR (x)
1367         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (d-sel . ,d-sel)))
1368          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1369            (clone info #:text (append (.text expr)
1370                                       ((accu->ident info) name)))))
1371
1372
1373         ;; TYPE (x) = PAIR;
1374         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (ident ,constant))))
1375          (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
1376                 (b (assoc-ref (.constants info) constant))
1377
1378                 (struct-type "scm") ;; FIXME
1379                 (struct (assoc-ref (.types info) struct-type))
1380                 (size (length struct))
1381                 (field-size 4) ;; FIXME:4, not fixed
1382                 (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))))
1383            (clone info #:text (append (.text expr)
1384                                       (list (lambda (f g t d)
1385                                               (i386:value->accu-ref+n offset b)))))))
1386
1387         ;; CAR (x) = 0
1388         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (fixed ,value))))
1389          (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
1390                 (b (cstring->number value))
1391                 
1392                 (struct-type "scm") ;; FIXME
1393                 (struct (assoc-ref (.types info) struct-type))
1394                 (size (length struct))
1395                 (field-size 4) ;; FIXME:4, not fixed
1396                 (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))               )
1397            (clone info #:text (append (.text expr)
1398                                       (list (lambda (f g t d)
1399                                               (i386:value->accu-ref+n offset b)))))))
1400
1401         ;; g_cells[0] = 65;
1402         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
1403          (let ((index (cstring->number index))
1404                (value (cstring->number value)))
1405           (clone info #:text
1406                  (append text
1407                          ((ident->base info) name)
1408                          ((ident->accu info) index)
1409                          (list (lambda (f g t d)
1410                                  (i386:accu+base)
1411                                  (i386:value->accu-ref value)))))))
1412
1413         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (char ,value))))
1414          (let ((index (cstring->number index))
1415                (value (char->integer (car (string->list value)))))
1416           (clone info #:text
1417                  (append text
1418                          ((ident->base info) name)
1419                          ((ident->accu info) index)
1420                          (list (lambda (f g t d)
1421                                  (i386:accu+base)
1422                                  (i386:value->accu-ref value)))))))
1423
1424         (_
1425          (format (current-error-port) "SKIP statement=~s\n" o)
1426          info)))))
1427
1428 (define (info->exe info)
1429   (display "dumping elf\n" (current-error-port))
1430   (map write-any (make-elf (.functions info) (.globals info))))
1431
1432 (define (.formals o)
1433   (pmatch o
1434     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1435     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1436     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
1437        barf)))
1438
1439 (define (formal->text n)
1440   (lambda (o i)
1441     ;;(i386:formal i n)
1442     '()
1443     ))
1444
1445 (define (formals->text o)
1446   (pmatch o
1447     ((param-list . ,formals)
1448      (let ((n (length formals)))
1449        (list (lambda (f g t d)
1450                (append
1451                 (i386:function-preamble)
1452                 (append-map (formal->text n) formals (iota n))
1453                 (i386:function-locals))))))
1454     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
1455        barf)))
1456
1457 (define (formals->locals o)
1458   (pmatch o
1459     ((param-list . ,formals)
1460      (let ((n (length formals)))
1461        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
1462        (map cons (map .name formals) (iota n -2 -1))))
1463     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
1464        barf)))
1465
1466 (define (function->info info)
1467   (lambda (o)
1468     ;;(stderr "\n")
1469     ;;(stderr "formals=~a\n" (.formals o))
1470     (let* ((name (.name o))
1471            (text (formals->text (.formals o)))
1472            (locals (formals->locals (.formals o))))
1473       (format (current-error-port) "compiling ~a\n" name)
1474       ;;(stderr "locals=~a\n" locals)
1475       (let loop ((statements (.statements o))
1476                  (info (clone info #:locals locals #:function name #:text text)))
1477         (if (null? statements) (clone info
1478                                       #:function #f
1479                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
1480             (let* ((statement (car statements)))
1481               (loop (cdr statements)
1482                     ((ast->info info) (car statements)))))))))
1483
1484 (define (ast-list->info info)
1485   (lambda (elements)
1486     (let loop ((elements elements) (info info))
1487       (if (null? elements) info
1488           (loop (cdr elements) ((ast->info info) (car elements)))))))
1489
1490 (define _start
1491   (let* ((argc-argv
1492           (string-append ".byte"
1493                          " 0x89 0xe8"      ; mov    %ebp,%eax
1494                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
1495                          " 0x50"           ; push   %eax
1496                          " 0x89 0xe8"      ; mov    %ebp,%eax
1497                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
1498                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
1499                          " 0x50"           ; push   %eax
1500                          ))
1501          (ast (with-input-from-string
1502                   
1503                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
1504                 parse-c99)))
1505     ast))
1506
1507 (define strlen
1508   (let* ((ast (with-input-from-string
1509                   "
1510 int
1511 strlen (char const* s)
1512 {
1513   int i = 0;
1514   while (s[i]) i++;
1515   return i;
1516 }
1517 "
1518 ;;paredit:"
1519                 parse-c99)))
1520     ast))
1521
1522 (define getchar
1523   (let* ((ast (with-input-from-string
1524                   "
1525 int
1526 getchar ()
1527 {
1528   char c1;
1529   int r = read (g_stdin, &c1, 1);
1530   //int r = read (0, &c1, 1);
1531   if (r < 1) return -1;
1532   return c1;
1533 }
1534 "
1535 ;;paredit:"
1536                 parse-c99)))
1537     ast))
1538
1539 (define putchar
1540   (let* ((ast (with-input-from-string
1541                   "
1542 int
1543 putchar (int c)
1544 {
1545   //write (STDOUT, s, strlen (s));
1546   //int i = write (STDOUT, s, strlen (s));
1547   write (1, (char*)&c, 1);
1548   return 0;
1549 }
1550 "
1551 ;;paredit:"
1552                 parse-c99)))
1553     ast))
1554
1555 (define eputs
1556   (let* ((ast (with-input-from-string
1557                   "
1558 int
1559 eputs (char const* s)
1560 {
1561   //write (STDERR, s, strlen (s));
1562   //write (2, s, strlen (s));
1563   int i = strlen (s);
1564   write (2, s, i);
1565   return 0;
1566 }
1567 "
1568 ;;paredit:"
1569                 parse-c99)))
1570     ast))
1571
1572 (define fputs
1573   (let* ((ast (with-input-from-string
1574                   "
1575 int
1576 fputs (char const* s, int fd)
1577 {
1578   int i = strlen (s);
1579   write (fd, s, i);
1580   return 0;
1581 }
1582 "
1583 ;;paredit:"
1584                 parse-c99)))
1585     ast))
1586
1587 (define puts
1588   (let* ((ast (with-input-from-string
1589                   "
1590 int
1591 puts (char const* s)
1592 {
1593   //write (STDOUT, s, strlen (s));
1594   //int i = write (STDOUT, s, strlen (s));
1595   int i = strlen (s);
1596   write (1, s, i);
1597   return 0;
1598 }
1599 "
1600 ;;paredit:"
1601                 parse-c99)))
1602     ast))
1603
1604 (define strcmp
1605   (let* ((ast (with-input-from-string
1606                   "
1607 int
1608 strcmp (char const* a, char const* b)
1609 {
1610   while (*a && *b && *a == *b) 
1611     {
1612       a++;b++;
1613     }
1614   return *a - *b;
1615 }
1616 "
1617 ;;paredit:"
1618                 parse-c99)))
1619     ast))
1620
1621 (define i386:libc
1622   (list
1623    (cons "exit" (list i386:exit))
1624    (cons "open" (list i386:open))
1625    (cons "read" (list i386:read))
1626    (cons "write" (list i386:write))))
1627
1628 (define libc
1629   (list
1630    strlen
1631    getchar
1632    putchar
1633    eputs
1634    fputs
1635    puts
1636    strcmp))
1637
1638 (define (compile)
1639   (let* ((ast (mescc))
1640          (info (make <info> #:functions i386:libc))
1641          (ast (append libc ast))
1642          (info ((ast->info info) ast))
1643          (info ((ast->info info) _start)))
1644     (info->exe info)))