mescc: Support global pointer assignments.
[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
941            (clone info #:text (append (.text expr)
942                                       (list (lambda (f g t d)
943                                               (i386:value->accu-ref+n offset b)))))))
944
945         ((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
946          (let ((b (cstring->number b)))
947            (clone info #:text
948                   (append text
949                           ((ident->base info) a)
950                           (list (lambda (f g t d)
951                                   (append
952                                    (i386:value->accu b)
953                                    (i386:sub-base))))))))
954
955         ((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
956          (let ((b (- (cstring->number b))))
957            (clone info #:text
958                   (append text
959                           ((ident->base info) a)
960                           (list (lambda (f g t d)
961                                   (append 
962                                    (i386:value->accu b)
963                                    (i386:sub-base))))))))        
964
965         
966         ((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
967          (let ((b (cstring->number b)))
968            (clone info #:text
969                   (append text
970                           ((ident->base info) a)
971                           (list (lambda (f g t d)
972                                   (append 
973                                    (i386:value->accu b)
974                                    (i386:sub-base)
975                                    (i386:xor-zf))))))))
976
977         ((ne (p-expr (ident ,a)) (p-expr (char ,b)))
978          (let ((b (char->integer (car (string->list b)))))
979            (clone info #:text
980                   (append text
981                           ((ident->base info) a)
982                           (list (lambda (f g t d)
983                                   (append 
984                                    (i386:value->accu b)
985                                    (i386:sub-base)
986                                    (i386:xor-zf))))))))        
987
988         ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
989          (let ((b (- (cstring->number b))))
990            (clone info #:text
991                   (append text
992                           ((ident->base info) a)
993                           (list (lambda (f g t d)
994                                   (append
995                                    (i386:value->accu b)
996                                    (i386:sub-base)
997                                    (i386:xor-zf))))))))
998
999         ((ne (p-expr (ident ,a)) (p-expr (ident ,constant)))
1000          (let ((b (assoc-ref (.constants info) constant)))
1001            (clone info #:text
1002                   (append text
1003                           ((ident->base info) a)
1004                           (list (lambda (f g t d)
1005                                   (append
1006                                    (i386:value->accu b)
1007                                    (i386:sub-base)
1008                                    (i386:xor-zf))))))))
1009         
1010         ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
1011          (let ((b (cstring->number b))
1012                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1013            (clone info #:text
1014                   (append text
1015                           (.text info)
1016                           (list (lambda (f g t d)
1017                                   (append
1018                                    (i386:value->base b)
1019                                    (i386:sub-base)
1020                                    (i386:xor-zf))))))))
1021
1022         ((ne (fctn-call . ,call) (p-expr (ident ,b)))
1023          (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1024            (clone info #:text
1025                   (append text
1026                           (.text info)
1027                           ((ident->base info) b)
1028                           (list (lambda (f g t d)
1029                                   (append
1030                                    (i386:sub-base)
1031                                    (i386:xor-zf))))))))
1032
1033         ((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1034            (clone info #:text
1035                   (append text
1036                           ((ident->accu info) a)
1037                           (list (lambda (f g t d)
1038                                   (append
1039                                    (i386:byte-mem->base)
1040                                    (i386:local->accu (assoc-ref locals b))
1041                                    (i386:byte-mem->accu)
1042                                    (i386:byte-test-base)
1043                                    (i386:xor-zf)))))))
1044
1045         ((ne (de-ref (p-expr (ident ,a))) (p-expr (char ,b)))
1046          (let ((b (char->integer (car (string->list b)))))
1047            (clone info #:text
1048                   (append text
1049                           ((ident->accu info) a)
1050                           (list (lambda (f g t d)
1051                                   (append
1052                                    (i386:byte-mem->base)
1053                                    (i386:value->accu b)
1054                                    (i386:byte-test-base)
1055                                    (i386:xor-zf))))))))
1056
1057         ;; CAR (x) != 1 // cell_nil
1058         ((ne (d-sel . ,d-sel) (p-expr (fixed ,b)))
1059          (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
1060                (b (cstring->number b)))
1061            (clone info #:text
1062                   (append text
1063                           (.text expr)
1064                           (list (lambda (f g t d)
1065                                   (append
1066                                    (i386:value->base b)
1067                                    (i386:sub-base)
1068                                    (i386:xor-zf))))))))
1069
1070         ;; CAR (x) != PAIR
1071         ((ne (d-sel . ,d-sel) (p-expr (ident ,constant)))
1072          (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
1073                (b (assoc-ref (.constants info) constant)))
1074            (clone info #:text
1075                   (append text
1076                           (.text expr)
1077                           (list (lambda (f g t d)
1078                                   (append
1079                                    (i386:value->base b)
1080                                    (i386:sub-base)
1081                                    (i386:xor-zf))))))))
1082
1083         ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
1084          (let ((b (cstring->number b)))
1085            (clone info #:text
1086                   (append text
1087                           ((ident->base info) a)
1088                           (list (lambda (f g t d)
1089                                   (append 
1090                                    (i386:value->accu b)
1091                                    (i386:base-sub))))))))
1092
1093         ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1094          (clone info #:text
1095                 (append text
1096                         (list (lambda (f g t d)
1097                                 (append
1098                                  ;;(and (stderr "006\n") '())
1099                                  (i386:local->accu (assoc-ref locals a))
1100                                  (i386:byte-mem->base)
1101                                  (i386:local->accu (assoc-ref locals b))
1102                                  (i386:byte-mem->accu)
1103                                  (i386:byte-sub-base)))))))
1104
1105         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
1106          (let ((value (cstring->number value)))
1107            (clone info #:text
1108                   (append text
1109                           ((ident->base info) name)
1110                           (list (lambda (f g t d)
1111                                        (append
1112                                         (i386:value->accu value)
1113                                         (i386:byte-base-mem->accu)))))))) ; FIXME: type: char
1114         
1115         ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
1116          (clone info #:text
1117                 (append text
1118                         ((ident->base info) name)
1119                         ((ident->accu info) index)
1120                         (list (lambda (f g t d)
1121                                 (i386:byte-base-mem->accu)))))) ; FIXME: type: char
1122         
1123         ((return ,expr)
1124          (let ((accu ((expr->accu info) expr)))
1125            (if (info? accu)
1126                (clone accu #:text
1127                       (append (.text accu) (list (i386:ret (lambda _ '())))))
1128                (clone info #:text
1129                       (append text (list (i386:ret accu)))))))
1130
1131         ;; int i;
1132         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1133          (clone info #:locals (add-local name)))
1134
1135         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1136          (let* ((locals (add-local name))
1137                 (info (clone info #:locals locals)))
1138            (let ((value (cstring->number value)))
1139              (clone info #:text
1140                     (append text ((value->ident info) name value))))))
1141
1142         ;; int i = 0;
1143         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1144          (let* ((locals (add-local name))
1145                 (info (clone info #:locals locals))
1146                 (value (cstring->number value)))
1147            (clone info #:text
1148                   (append text
1149                           ((value->ident info) name value)))))
1150
1151         ;; char c = 'A';
1152         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1153          (let* ((locals (add-local name))
1154                 (info (clone info #:locals locals))
1155                 (value (char->integer (car (string->list value)))))
1156            (clone info #:text
1157                   (append text
1158                           ((value->ident info) name value)))))
1159
1160         ;; int i = -1;
1161         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1162          (let* ((locals (add-local name))
1163                 (info (clone info #:locals locals))
1164                 (value (- (cstring->number value))))
1165            (clone info #:text
1166                   (append text
1167                           ((value->ident info) name value)))))
1168
1169         ;; int i = argc;
1170         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1171          (let* ((locals (add-local name))
1172                 (info (clone info #:locals locals)))
1173            (clone info #:text
1174                   (append text
1175                           ((ident->accu info) local)
1176                           ((accu->ident info) name)))))
1177
1178         ;; char *p = "t.c";
1179         ;;(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"))))))
1180         ((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
1181          (let* ((locals (add-local name))
1182                 (globals (append globals (list (string->global value))))
1183                 (info (clone info #:locals locals #:globals globals)))
1184            (clone info #:text
1185                   (append text
1186                           (list (lambda (f g t d)
1187                                   (append
1188                                    (i386:global->accu (+ (data-offset value g) d)))))
1189                           ((accu->ident info) name)))))
1190         
1191         ;; char arena[20000];
1192         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1193          (let* ((globals (.globals info))
1194                 (count (cstring->number count))
1195                 (size 1) ;; FIXME
1196                 (array (list (ident->global name #xaaaaaaaa)))  ;;FIXME: deref?
1197                 (dummy (list (cons (string->list "dummy")
1198                                    (string->list (make-string (* count size) #\nul))))))
1199            (clone info #:globals (append globals array dummy))))
1200
1201         ;; struct scm* arena[200];
1202         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1203          (let* ((globals (.globals info))
1204                 (count (cstring->number count))
1205                 (size 12) ;; FIXME
1206                 (array (list (ident->global name #x58585858)))  ;;FIXME: deref?
1207                 (dummy (list (cons (string->list "dummy")
1208                                    (string->list (make-string (* count size) #\nul))))))
1209            (stderr "(* count size): ~a\n" (* count size))
1210            (clone info #:globals (append globals array dummy))))
1211
1212         ;;struct scm *g_cells = (struct scm*)arena;
1213         ((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)))))))
1214          (let* ((locals (add-local name))
1215                 (info (clone info #:locals locals)))
1216            (clone info #:text
1217                   (append text
1218                           ((ident->accu info) name)
1219                           ((accu->ident info) value))))) ;; FIXME: deref?
1220
1221         ;; SCM g_stack = 0;
1222         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1223          ((ast->info info) (list-head o (- (length o) 1))))
1224
1225         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1226          (if (.function info)
1227              (let* ((locals (add-local name))
1228                     (globals (append globals (list (string->global value))))
1229                     (info (clone info #:locals locals #:globals globals)))
1230                (clone info #:text
1231                       (append text
1232                               (list (lambda (f g t d)
1233                                       (append
1234                                        (i386:global->accu (+ (data-offset value g) d)))))
1235                               ((accu->ident info) name))))
1236              (let* ((value (length (globals->data globals)))
1237                     (globals (append globals (list (ident->global name value)))))
1238                (clone info #:globals globals))))
1239
1240         ;; SCM i = argc;
1241         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1242          (let* ((locals (add-local name))
1243                (info (clone info #:locals locals)))
1244            (clone info #:text
1245                   (append text
1246                           ((ident->accu info) local)
1247                           ((accu->ident info) name)))))
1248         
1249         ;; int i = f ();
1250         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1251          (let* ((locals (add-local name))
1252                 (info (clone info #:locals locals)))
1253            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1254              (clone info
1255                     #:text
1256                     (append (.text info)
1257                             ((accu->ident info) name))
1258                     #:locals locals))))
1259         
1260         ;; SCM x = car (e);
1261         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1262          (let* ((locals (add-local name))
1263                 (info (clone info #:locals locals)))
1264            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1265              (clone info
1266                     #:text
1267                     (append (.text info)
1268                             ((accu->ident info) name))))))
1269
1270         ;; char *p = (char*)g_cells;
1271         ((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)))))))
1272          (let* ((locals (add-local name))
1273                 (info (clone info #:locals locals)))
1274            (clone info #:text
1275                   (append text
1276                           ((ident->accu info) value)
1277                           ((accu->ident info) name)))))
1278
1279         ;; char *p = g_cells;
1280         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1281          (let* ((locals (add-local name))
1282                 (info (clone info #:locals locals)))
1283            (clone info #:text
1284                   (append text
1285                           ((ident->accu info) value)
1286                           ((accu->ident info) name)))))
1287
1288         ;; enum 
1289         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1290          (let ((type (ident->type name "enum"))
1291                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1292            (clone info #:types (append (.types info) (list type))
1293                   #:constants (append constants (.constants info)))))
1294
1295         ;; struct
1296         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1297          (let* ((type (ident->type name (map struct-field fields))))
1298            (clone info #:types (append (.types info) (list type)))))
1299         
1300         ;; i = 0;
1301         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
1302          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
1303          (let ((value (cstring->number value)))
1304            (clone info #:text (append text ((value->ident info) name value)))))
1305
1306         ;; i = 0; ...from for init FIXME
1307         ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
1308          (let ((value (cstring->number value)))
1309            (clone info #:text (append text ((value->ident info) name value)))))
1310
1311         ;; i = i + 48;
1312         ((expr-stmt (assn-expr (p-expr (ident ,a)) (op _) (add (p-expr (ident ,b)) (p-expr (fixed ,value)))))
1313          (let ((value (cstring->number value)))
1314            (clone info #:text
1315                   (append text
1316                           ((ident->base info) b)
1317                           (list (lambda (f g t d)
1318                                   (append
1319                                    (i386:value->accu value)
1320                                    (i386:accu+base))))
1321                           ((accu->ident info) a)))))
1322
1323         ;; c = 'A';
1324         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (char ,value))))
1325          (let ((value (char->integer (car (string->list value)))))
1326            (clone info #:text (append text ((value->ident info) name value)))))
1327
1328         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
1329          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1330            (clone info #:text (append (.text info) ((accu->ident info) name)))))
1331
1332         ;; p = g_cell;
1333         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (ident ,value))))
1334          (clone info #:text
1335                 (append text
1336                         ((ident->accu info) value)
1337                         ((accu->ident info) name))))
1338
1339         ;; *p = 0;
1340         ((expr-stmt (assn-expr (de-ref (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
1341          (let ((value (cstring->number value)))
1342            (clone info #:text (append text
1343                                       (list (lambda (f g t d)
1344                                               (i386:value->base 0)))
1345                                       ((base->ident-ref info) name)))))
1346
1347         ;; *p++ = c;
1348         ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op _) (p-expr (ident ,value))))
1349          ;; (stderr "VALUE: ~a\n" value)
1350          ;; (stderr "LOCALS: ~a\n" (.locals info))
1351          ;; (stderr " ==> ~a\n" (assoc-ref (.locals info) value))
1352          (clone info #:text
1353                 (append text
1354                         ;;((ident-ref->base info) value)
1355                         ((ident->base info) value)
1356                         ((base->ident-ref info) name)
1357                         (list (lambda (f g t d)
1358                                 (i386:local-add (assoc-ref locals name) 1))))))
1359
1360         ((d-sel . ,d-sel)
1361          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1362            expr))        
1363
1364         ;; i = CAR (x)
1365         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (d-sel . ,d-sel)))
1366          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1367            (clone info #:text (append (.text expr)
1368                                       ((accu->ident info) name)))))
1369
1370
1371         ;; TYPE (x) = PAIR;
1372         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (ident ,constant))))
1373          (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
1374                 (b (assoc-ref (.constants info) constant))
1375
1376                 (struct-type "scm") ;; FIXME
1377                 (struct (assoc-ref (.types info) struct-type))
1378                 (size (length struct))
1379                 (field-size 4) ;; FIXME:4, not fixed
1380                 (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))))
1381            (clone info #:text (append (.text expr)
1382                                       (list (lambda (f g t d)
1383                                               (i386:value->accu-ref+n offset b)))))))
1384
1385         ;; CAR (x) = 0
1386         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (fixed ,value))))
1387          (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
1388                 (b (cstring->number value))
1389                 
1390                 (struct-type "scm") ;; FIXME
1391                 (struct (assoc-ref (.types info) struct-type))
1392                 (size (length struct))
1393                 (field-size 4) ;; FIXME:4, not fixed
1394                 (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))               )
1395            (clone info #:text (append (.text expr)
1396                                       (list (lambda (f g t d)
1397                                               (i386:value->accu-ref+n offset b)))))))
1398
1399         ;; g_cells[0] = 65;
1400         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
1401          (let ((index (cstring->number index))
1402                (value (cstring->number value)))
1403           (clone info #:text
1404                  (append text
1405                          ((ident->base info) name)
1406                          ((ident->accu info) index)
1407                          (list (lambda (f g t d)
1408                                  (i386:accu+base)
1409                                  (i386:value->accu-ref value)))))))
1410
1411         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (char ,value))))
1412          (let ((index (cstring->number index))
1413                (value (char->integer (car (string->list value)))))
1414           (clone info #:text
1415                  (append text
1416                          ((ident->base info) name)
1417                          ((ident->accu info) index)
1418                          (list (lambda (f g t d)
1419                                  (i386:accu+base)
1420                                  (i386:value->accu-ref value)))))))
1421
1422         (_
1423          (format (current-error-port) "SKIP statement=~s\n" o)
1424          info)))))
1425
1426 (define (info->exe info)
1427   (display "dumping elf\n" (current-error-port))
1428   (map write-any (make-elf (.functions info) (.globals info))))
1429
1430 (define (.formals o)
1431   (pmatch o
1432     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1433     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1434     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
1435        barf)))
1436
1437 (define (formal->text n)
1438   (lambda (o i)
1439     ;;(i386:formal i n)
1440     '()
1441     ))
1442
1443 (define (formals->text o)
1444   (pmatch o
1445     ((param-list . ,formals)
1446      (let ((n (length formals)))
1447        (list (lambda (f g t d)
1448                (append
1449                 (i386:function-preamble)
1450                 (append-map (formal->text n) formals (iota n))
1451                 (i386:function-locals))))))
1452     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
1453        barf)))
1454
1455 (define (formals->locals o)
1456   (pmatch o
1457     ((param-list . ,formals)
1458      (let ((n (length formals)))
1459        ;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
1460        (map cons (map .name formals) (iota n -2 -1))))
1461     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
1462        barf)))
1463
1464 (define (function->info info)
1465   (lambda (o)
1466     ;;(stderr "\n")
1467     ;;(stderr "formals=~a\n" (.formals o))
1468     (let* ((name (.name o))
1469            (text (formals->text (.formals o)))
1470            (locals (formals->locals (.formals o))))
1471       (format (current-error-port) "compiling ~a\n" name)
1472       ;;(stderr "locals=~a\n" locals)
1473       (let loop ((statements (.statements o))
1474                  (info (clone info #:locals locals #:function name #:text text)))
1475         (if (null? statements) (clone info
1476                                       #:function #f
1477                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
1478             (let* ((statement (car statements)))
1479               (loop (cdr statements)
1480                     ((ast->info info) (car statements)))))))))
1481
1482 (define (ast-list->info info)
1483   (lambda (elements)
1484     (let loop ((elements elements) (info info))
1485       (if (null? elements) info
1486           (loop (cdr elements) ((ast->info info) (car elements)))))))
1487
1488 (define _start
1489   (let* ((argc-argv
1490           (string-append ".byte"
1491                          " 0x89 0xe8"      ; mov    %ebp,%eax
1492                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
1493                          " 0x50"           ; push   %eax
1494                          " 0x89 0xe8"      ; mov    %ebp,%eax
1495                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
1496                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
1497                          " 0x50"           ; push   %eax
1498                          ))
1499          (ast (with-input-from-string
1500                   
1501                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
1502                 parse-c99)))
1503     ast))
1504
1505 (define strlen
1506   (let* ((ast (with-input-from-string
1507                   "
1508 int
1509 strlen (char const* s)
1510 {
1511   int i = 0;
1512   while (s[i]) i++;
1513   return i;
1514 }
1515 "
1516 ;;paredit:"
1517                 parse-c99)))
1518     ast))
1519
1520 (define getchar
1521   (let* ((ast (with-input-from-string
1522                   "
1523 int
1524 getchar ()
1525 {
1526   char c1;
1527   int r = read (g_stdin, &c1, 1);
1528   //int r = read (0, &c1, 1);
1529   if (r < 1) return -1;
1530   return c1;
1531 }
1532 "
1533 ;;paredit:"
1534                 parse-c99)))
1535     ast))
1536
1537 (define putchar
1538   (let* ((ast (with-input-from-string
1539                   "
1540 int
1541 putchar (int c)
1542 {
1543   //write (STDOUT, s, strlen (s));
1544   //int i = write (STDOUT, s, strlen (s));
1545   write (1, (char*)&c, 1);
1546   return 0;
1547 }
1548 "
1549 ;;paredit:"
1550                 parse-c99)))
1551     ast))
1552
1553 (define eputs
1554   (let* ((ast (with-input-from-string
1555                   "
1556 int
1557 eputs (char const* s)
1558 {
1559   //write (STDERR, s, strlen (s));
1560   //write (2, s, strlen (s));
1561   int i = strlen (s);
1562   write (2, s, i);
1563   return 0;
1564 }
1565 "
1566 ;;paredit:"
1567                 parse-c99)))
1568     ast))
1569
1570 (define fputs
1571   (let* ((ast (with-input-from-string
1572                   "
1573 int
1574 fputs (char const* s, int fd)
1575 {
1576   int i = strlen (s);
1577   write (fd, s, i);
1578   return 0;
1579 }
1580 "
1581 ;;paredit:"
1582                 parse-c99)))
1583     ast))
1584
1585 (define puts
1586   (let* ((ast (with-input-from-string
1587                   "
1588 int
1589 puts (char const* s)
1590 {
1591   //write (STDOUT, s, strlen (s));
1592   //int i = write (STDOUT, s, strlen (s));
1593   int i = strlen (s);
1594   write (1, s, i);
1595   return 0;
1596 }
1597 "
1598 ;;paredit:"
1599                 parse-c99)))
1600     ast))
1601
1602 (define strcmp
1603   (let* ((ast (with-input-from-string
1604                   "
1605 int
1606 strcmp (char const* a, char const* b)
1607 {
1608   while (*a && *b && *a == *b) 
1609     {
1610       a++;b++;
1611     }
1612   return *a - *b;
1613 }
1614 "
1615 ;;paredit:"
1616                 parse-c99)))
1617     ast))
1618
1619 (define i386:libc
1620   (list
1621    (cons "exit" (list i386:exit))
1622    (cons "open" (list i386:open))
1623    (cons "read" (list i386:read))
1624    (cons "write" (list i386:write))))
1625
1626 (define libc
1627   (list
1628    strlen
1629    getchar
1630    putchar
1631    eputs
1632    fputs
1633    puts
1634    strcmp))
1635
1636 (define (compile)
1637   (let* ((ast (mescc))
1638          (info (make <info> #:functions i386:libc))
1639          (ast (append libc ast))
1640          (info ((ast->info info) ast))
1641          (info ((ast->info info) _start)))
1642     (info->exe info)))