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