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