mescc: Struct by value.
[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 "pointer_cells4[]: ~s\n" array)
2035          (when (not (equal? op "="))
2036            (stderr "OOOPS4: op=~s\n" op)
2037            barf)
2038          (let* ((empty (clone info #:text '()))
2039                 (base ((expr->base empty) b))
2040                 (type (ident->type info array))
2041                 (fields (or (type->description info type) '()))  ;; FIXME: struct!
2042                 (size (type->size info type))
2043                 (count (length fields))
2044                 (field-size 4) ;; FIXME:4, not fixed
2045                 (ptr (ident->pointer info array)))
2046            (clone info #:text
2047                   (append text
2048                           (.text base)
2049                           (list (lambda (f g ta t d)
2050                                   (i386:push-base)))
2051                           ((ident->base info) index)
2052                           (list (lambda (f g ta t d)
2053                                   (append
2054                                    (i386:base->accu)
2055                                    (if (> count 1) (i386:accu+accu) '())
2056                                    (if (= count 3) (i386:accu+base) '())
2057                                    (i386:accu-shl 2))))
2058                           ((ident->base info) array)
2059                           (list (lambda (f g ta t d)
2060                                   (i386:accu+base)))
2061                          (list (lambda (f g ta t d)
2062                                  (i386:pop-base)))
2063                          (cond ((equal? array "g_functions") ;; FIXME
2064                                 (list (lambda (f g ta t d)
2065                                         (append
2066                                          (i386:base-address->accu-address)
2067                                          (i386:accu+n 4)
2068                                          (i386:base+n 4)
2069                                          (i386:base-address->accu-address)
2070                                          (i386:accu+n 4)
2071                                          (i386:base+n 4)
2072                                          (i386:base-address->accu-address)))))
2073                                (else (list (lambda (f g ta t d)
2074                                              (i386:base->accu-address)))))))))
2075
2076         ;; g_functions[g_function++] = g_foo;
2077         ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
2078          (when (not (equal? op "="))
2079            (stderr "OOOPS5: op=~s\n" op)
2080            barf)
2081          (let* ((empty (clone info #:text '()))
2082                 (base ((expr->base empty) b))
2083                 (type (ident->type info array))
2084                 (fields (or (type->description info type) '()))  ;; FIXME: struct!
2085                 (size (type->size info type))
2086                 (count (length fields))
2087                 (field-size 4) ;; FIXME:4, not fixed
2088                 (ptr (ident->pointer info array)))
2089            (clone info #:text
2090                   (append text
2091                           (.text base)
2092                           (list (lambda (f g ta t d)
2093                                   (i386:push-base)))
2094                           ((ident->base info) index)
2095                           (list (lambda (f g ta t d)
2096                                   (append
2097                                    (i386:base->accu)
2098                                    (if (> count 1) (i386:accu+accu) '())
2099                                    (if (= count 3) (i386:accu+base) '())
2100                                    (i386:accu-shl 2))))
2101                           ((ident->base info) array)
2102                           (list (lambda (f g ta t d)
2103                                   (i386:accu+base)))
2104                          (list (lambda (f g ta t d)
2105                                  (i386:pop-base)))
2106                          ;; FIXME
2107                          (cond ((equal? array "g_functions") ;; FIXME
2108                                 (list (lambda (f g ta t d)
2109                                         (append
2110                                          (i386:base-address->accu-address)
2111                                          (i386:accu+n 4)
2112                                          (i386:base+n 4)
2113                                          (i386:base-address->accu-address)
2114                                          (i386:accu+n 4)
2115                                          (i386:base+n 4)
2116                                          (i386:base-address->accu-address)))))
2117                                (else (list (lambda (f g ta t d)
2118                                              (i386:base->accu-address)))))
2119                          ((ident-add info) index 1)))))
2120
2121         ;; DECL
2122         ;;
2123         ;; struct f = {...};
2124         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2125          (let* ((type (decl->type type))
2126                 ;;(foo (stderr "1DECL: ~s\n" type))
2127                 (fields (type->description info type))
2128                 (size (type->size info type))
2129                 (field-size 4))  ;; FIXME:4, not fixed
2130            ;;(stderr  "7TYPE: ~s\n" type)
2131            (if (.function info)
2132                (let* ((globals (append globals (filter-map initzer->global initzers)))
2133                       (locals (let loop ((fields (cdr fields)) (locals locals))
2134                                 (if (null? fields) locals
2135                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2136                       (locals (add-local locals name type -1))
2137                       (info (clone info #:locals locals #:globals globals))
2138                       (empty (clone info #:text '())))
2139                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2140                    (if (null? fields) info
2141                        (let ((offset (* field-size (car fields)))
2142                              (initzer (car initzers)))
2143                          (loop (cdr fields) (cdr initzers)
2144                                (clone info #:text
2145                                       (append
2146                                        (.text info)
2147                                        ((ident->accu info) name)
2148                                        (list (lambda (f g ta t d)
2149                                                (append
2150                                                 (i386:accu->base))))
2151                                        (.text ((expr->accu empty) initzer))
2152                                        (list (lambda (f g ta t d)
2153                                                (i386:accu->base-address+n offset))))))))))
2154                (let* ((globals (append globals (filter-map initzer->global initzers)))
2155                       (global (make-global name type -1 (string->list (make-string size #\nul))))
2156                       (globals (append globals (list global)))
2157                       (here (data-offset name globals))
2158                       (info (clone info #:globals globals))
2159                       (field-size 4))
2160                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2161                    (if (null? fields) info
2162                        (let ((offset (* field-size (car fields)))
2163                              (initzer (car initzers)))
2164                          (loop (cdr fields) (cdr initzers)
2165                                (clone info #:init
2166                                       (append
2167                                        (.init info)
2168                                        (list (lambda (functions globals ta t d data)
2169                                                (append
2170                                                 (list-head data (+ here offset))
2171                                                 (initzer->data info functions globals ta t d (car initzers))
2172                                                 (list-tail data (+ here offset field-size)))))))))))))))
2173
2174
2175         ;;char cc = g_cells[c].cdr;  ==> generic?
2176         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2177          (let ((type (decl->type type)))
2178            (if (.function info)
2179                (let* ((locals (add-local locals name type 0))
2180                       (info (clone info #:locals locals)))
2181                  (clone info #:text
2182                         (append (.text ((expr->accu info) initzer))
2183                                 ((accu->ident info) name))))
2184                (let* ((globals (append globals (list (ident->global name type 1 0))))
2185                       (here (data-offset name globals)))
2186                  (clone info
2187                         #:globals globals
2188                         #:init (append (.init info)
2189                                        (list (lambda (functions globals ta t d data)
2190                                                (append
2191                                                 (list-head data here)
2192                                                 (initzer->data info functions globals ta t d initzer)
2193                                                 (list-tail data (+ here 4)))))))))))
2194
2195
2196         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2197          info)
2198
2199         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
2200          info)
2201
2202         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2203          (let ((types (.types info)))
2204            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
2205
2206         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2207          (format (current-error-port) "SKIP: typedef=~s\n" o)
2208          info)
2209
2210         ((decl (@ ,at))
2211          (format (current-error-port) "SKIP: at=~s\n" o)
2212          info)
2213
2214         ((decl . _)
2215          (format (current-error-port) "SKIP: decl statement=~s\n" o)
2216          barf
2217          info)
2218
2219         (_
2220          (format (current-error-port) "SKIP: statement=~s\n" o)
2221          barf
2222          info)))))
2223
2224 (define (initzer->data info functions globals ta t d o)
2225   (pmatch o
2226     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2227     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2228     ((initzer (ref-to (p-expr (ident ,name))))
2229      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2230      (int->bv32 (+ ta (function-offset name functions))))
2231     ((initzer (p-expr (ident ,name)))
2232      (let ((value (assoc-ref (.constants info) name)))
2233        (int->bv32 value)))
2234     ((initzer (p-expr (string ,string)))
2235      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2236     (_ (stderr "initzer->data:SKIP: ~s\n" o)
2237        barf
2238      (int->bv32 0))))
2239
2240 (define (info->exe info)
2241   (display "dumping elf\n" (current-error-port))
2242   (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2243
2244 (define (.formals o)
2245   (pmatch o
2246     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2247     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2248     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2249        barf)))
2250
2251 (define (formal->text n)
2252   (lambda (o i)
2253     ;;(i386:formal i n)
2254     '()
2255     ))
2256
2257 (define (formals->text o)
2258   (pmatch o
2259     ((param-list . ,formals)
2260      (let ((n (length formals)))
2261        (list (lambda (f g ta t d)
2262                (append
2263                 (i386:function-preamble)
2264                 (append-map (formal->text n) formals (iota n))
2265                 (i386:function-locals))))))
2266     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2267        barf)))
2268
2269 (define (formal:ptr o)
2270   (pmatch o
2271     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2272      1)
2273     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2274      0)
2275     (_
2276      (stderr "formal:ptr[~a] => 0\n" o)
2277      0)))
2278
2279 (define (formals->locals o)
2280   (pmatch o
2281     ((param-list . ,formals)
2282      (let ((n (length formals)))
2283        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2284     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2285        barf)))
2286
2287 (define (function->info info)
2288   (lambda (o)
2289     ;;(stderr "\n")
2290     ;;(stderr "formals=~a\n" (.formals o))
2291     (let* ((name (.name o))
2292            (text (formals->text (.formals o)))
2293            (locals (formals->locals (.formals o))))
2294       (format (current-error-port) "compiling ~a\n" name)
2295       ;;(stderr "locals=~a\n" locals)
2296       (let loop ((statements (.statements o))
2297                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2298         (if (null? statements) (clone info
2299                                       #:function #f
2300                                       #:functions (append (.functions info) (list (cons name (.text info)))))
2301             (let* ((statement (car statements)))
2302               (loop (cdr statements)
2303                     ((ast->info info) (car statements)))))))))
2304
2305 (define (ast-list->info info)
2306   (lambda (elements)
2307     (let loop ((elements elements) (info info))
2308       (if (null? elements) info
2309           (loop (cdr elements) ((ast->info info) (car elements)))))))
2310
2311 (define _start
2312   (let* ((argc-argv
2313           (string-append ".byte"
2314                          " 0x89 0xe8"      ; mov    %ebp,%eax
2315                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
2316                          " 0x50"           ; push   %eax
2317                          " 0x89 0xe8"      ; mov    %ebp,%eax
2318                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
2319                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
2320                          " 0x50"           ; push   %eax
2321                          ))
2322          (ast (with-input-from-string
2323                   
2324                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
2325                 parse-c99)))
2326     ast))
2327
2328 (define strlen
2329   (let* ((ast (with-input-from-string
2330                   "
2331 int
2332 strlen (char const* s)
2333 {
2334   int i = 0;
2335   while (s[i]) i++;
2336   return i;
2337 }
2338 "
2339 ;;paredit:"
2340                 parse-c99)))
2341     ast))
2342
2343 (define getchar
2344   (let* ((ast (with-input-from-string
2345                   "
2346 int g_stdin;
2347 int
2348 getchar ()
2349 {
2350   char c;
2351   int r = read (g_stdin, &c, 1);
2352   //int r = read (0, &c, 1);
2353   if (r < 1) return -1;
2354   return c;
2355 }
2356 "
2357 ;;paredit:"
2358                 parse-c99)))
2359     ast))
2360
2361 (define putchar
2362   (let* ((ast (with-input-from-string
2363                   "
2364 int
2365 putchar (int c)
2366 {
2367   //write (STDOUT, s, strlen (s));
2368   //int i = write (STDOUT, s, strlen (s));
2369   write (1, (char*)&c, 1);
2370   return 0;
2371 }
2372 "
2373 ;;paredit:"
2374                 parse-c99)))
2375     ast))
2376
2377 (define eputs
2378   (let* ((ast (with-input-from-string
2379                   "
2380 int
2381 eputs (char const* s)
2382 {
2383   //write (STDERR, s, strlen (s));
2384   //write (2, s, strlen (s));
2385   int i = strlen (s);
2386   write (2, s, i);
2387   return 0;
2388 }
2389 "
2390 ;;paredit:"
2391                 parse-c99)))
2392     ast))
2393
2394 (define fputs
2395   (let* ((ast (with-input-from-string
2396                   "
2397 int
2398 fputs (char const* s, int fd)
2399 {
2400   int i = strlen (s);
2401   write (fd, s, i);
2402   return 0;
2403 }
2404 "
2405 ;;paredit:"
2406                 parse-c99)))
2407     ast))
2408
2409 (define puts
2410   (let* ((ast (with-input-from-string
2411                   "
2412 int
2413 puts (char const* s)
2414 {
2415   //write (STDOUT, s, strlen (s));
2416   //int i = write (STDOUT, s, strlen (s));
2417   int i = strlen (s);
2418   write (1, s, i);
2419   return 0;
2420 }
2421 "
2422 ;;paredit:"
2423                 parse-c99)))
2424     ast))
2425
2426 (define strcmp
2427   (let* ((ast (with-input-from-string
2428                   "
2429 int
2430 strcmp (char const* a, char const* b)
2431 {
2432   while (*a && *b && *a == *b) 
2433     {
2434       a++;b++;
2435     }
2436   return *a - *b;
2437 }
2438 "
2439 ;;paredit:"
2440                 parse-c99)))
2441     ast))
2442
2443 (define i386:libc
2444   (list
2445    (cons "exit" (list i386:exit))
2446    (cons "open" (list i386:open))
2447    (cons "read" (list i386:read))
2448    (cons "write" (list i386:write))))
2449
2450 (define libc
2451   (list
2452    strlen
2453    getchar
2454    putchar
2455    eputs
2456    fputs
2457    puts
2458    strcmp))
2459
2460 (define (compile)
2461   (let* ((ast (mescc))
2462          (info (make <info>
2463                  #:functions i386:libc
2464                  #:types i386:type-alist))
2465          (ast (append libc ast))
2466          (info ((ast->info info) ast))
2467          (info ((ast->info info) _start)))
2468     (info->exe info)))