mescc: Refactor ret.
[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         ((assn-expr (p-expr (ident ,name)) ,op ,expr)
802          (let ((info ((ast->info info) o)))
803            (clone info #:text (append (.text info)
804                                       ((ident->accu info) name)))))
805
806         (_
807          (format (current-error-port) "SKIP: expr->accu=~s\n" o)
808          barf
809          info)))))
810
811 (define (expr->base info)
812   (lambda (o)
813     (let ((info ((expr->accu info) o)))
814       (clone info
815              #:text (append
816                      (list (lambda (f g ta t d)
817                              (i386:push-accu)))
818                      (.text info)
819                      (list (lambda (f g ta t d)
820                              (append
821                               (i386:accu->base)
822                               (i386:pop-accu)))))))))
823
824 (define (expr->accu* info)
825   (lambda (o)
826     (pmatch o
827       ;;(stderr "expr->accu* o=~s\n" o)
828       ;; g_cells[10].type
829       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
830        (let* ((type (ident->type info array))
831               (fields (or (type->description info type) '()))
832               (size (type->size info type))
833               (count (length fields))
834               (field-size 4) ;; FIXME:4, not fixed
835               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
836               (index (cstring->number index))
837               (text (.text info)))
838          (clone info #:text
839                 (append text
840                         (list (lambda (f g ta t d)
841                                 (append
842                                  (i386:value->base index)
843                                  (i386:base->accu)
844                                  (if (> count 1) (i386:accu+accu) '())
845                                  (if (= count 3) (i386:accu+base) '())
846                                  (i386:accu-shl 2))))
847                         ;; de-ref: g_cells, non: arena
848                         ;;((ident->base info) array)
849                         ((ident->base info) array)
850                         (list (lambda (f g ta t d)
851                                 (append
852                                  (i386:accu+base)
853                                  (i386:accu+value offset))))))))
854
855       ;; g_cells[x].type
856       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
857        (let* ((type (ident->type info array))
858               (fields (or (type->description info type) '()))
859               (size (type->size info type))
860               (count (length fields))
861               (field-size 4) ;; FIXME:4, not fixed
862               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
863               (text (.text info)))
864          (clone info #:text
865                 (append text
866                         ((ident->base info) index)
867                         (list (lambda (f g ta t d)
868                                 (append
869                                  (i386:base->accu)
870                                  (if (> count 1) (i386:accu+accu) '())
871                                  (if (= count 3) (i386:accu+base) '())
872                                  (i386:accu-shl 2))))
873                         ;; de-ref: g_cells, non: arena
874                         ;;((ident->base info) array)
875                         ((ident->base info) array)
876                         (list (lambda (f g ta t d)
877                                 (append
878                                  (i386:accu+base)
879                                  (i386:accu+value offset))))))))
880
881       ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
882       ((d-sel (ident ,field) (p-expr (ident ,name)))
883        (let* ((type (ident->type info name))
884               (fields (or (type->description info type) '()))
885               (field-size 4) ;; FIXME
886               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
887               (text (.text info)))
888          (clone info #:text
889                 (append text
890                         ((ident->accu info) name)
891                         (list (lambda (f g ta t d)
892                                 (i386:accu+value offset)))))))
893
894       (_
895        (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
896        barf
897        info)
898       )))
899
900 (define (ident->constant name value)
901   (cons name value))
902
903 (define (make-type name type size description)
904   (cons name (list type size description)))
905
906 (define (enum->type name fields)
907   (make-type name 'enum 4 fields))
908
909 (define (struct->type name fields)
910   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
911
912 (define (decl->type o)
913   (pmatch o
914     ((fixed-type ,type) type)
915     ((struct-ref (ident ,name)) (list "struct" name))
916     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
917      (list "struct" name)) ;; FIXME
918     ((typename ,name) name)
919     (_
920      (stderr "SKIP: decl type=~s\n" o)
921      barf
922      o)))
923
924 (define (expr->global o)
925   (pmatch o
926     ((p-expr (string ,string)) (string->global string))
927     (_ #f)))
928
929 (define (initzer->global o)
930   (pmatch o
931     ((initzer ,initzer) (expr->global initzer))
932     (_ #f)))
933
934 (define (byte->hex o)
935   (string->number (string-drop o 2) 16))
936
937 (define (asm->hex o)
938   (let ((prefix ".byte "))
939     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
940         (let ((s (string-drop o (string-length prefix))))
941           (map byte->hex (string-split s #\space))))))
942
943 (define (case->jump-info info)
944   (define (jump n)
945     (list (lambda (f g ta t d) (i386:Xjump n))))
946   (define (jump-nz n)
947     (list (lambda (f g ta t d) (i386:Xjump-nz n))))
948   (define (statement->info info body-length)
949     (lambda (o)
950       (pmatch o
951         ((break) (clone info #:text (append (.text info) (jump body-length)
952 )))
953         (_
954          ((ast->info info) o)))))
955   (lambda (o)
956     (pmatch o
957       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
958        (lambda (body-length)
959
960          (define (test->text value clause-length)
961            (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
962                    (jump-nz clause-length)))
963          (let* ((value (assoc-ref (.constants info) constant))
964                 (test-info
965                  (clone info #:text (append (.text info) (test->text value 0))))
966                 (text-length (length (.text test-info)))
967                 (clause-info (let loop ((elements elements) (info test-info))
968                                (if (null? elements) info
969                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
970                 (clause-text (list-tail (.text clause-info) text-length))
971                 (clause-length (length (text->list clause-text))))
972            (clone info #:text (append
973                                (.text info)
974                                (test->text value clause-length)
975                                clause-text)
976                   #:globals (.globals clause-info)))))
977
978       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
979        (lambda (body-length)
980
981          (define (test->text value clause-length)
982            (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
983                    (jump-nz clause-length)))
984          (let* ((value (cstring->number value))
985                 (test-info
986                  (clone info #:text (append (.text info) (test->text value 0))))
987                 (text-length (length (.text test-info)))
988                 (clause-info (let loop ((elements elements) (info test-info))
989                                (if (null? elements) info
990                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
991                 (clause-text (list-tail (.text clause-info) text-length))
992                 (clause-length (length (text->list clause-text))))
993            (clone info #:text (append
994                                (.text info)
995                                (test->text value clause-length)
996                                clause-text)
997                   #:globals (.globals clause-info)))))
998
999       ((case (neg (p-expr (fixed ,value))) ,statement)
1000        ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
1001
1002       ((default (compd-stmt (block-item-list . ,elements)))
1003        (lambda (body-length)
1004          (let ((text-length (length (.text info))))
1005           (let loop ((elements elements) (info info))
1006             (if (null? elements) info
1007                 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
1008
1009       ((case (p-expr (ident ,constant)) ,statement)
1010        ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
1011
1012       ((case (p-expr (fixed ,value)) ,statement)
1013        ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
1014
1015       ((default ,statement)
1016        ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
1017
1018       (_ (stderr "no case match: ~a\n" o) barf)
1019       )))
1020
1021 (define (test->jump->info info)
1022   (define (jump type . test)
1023     (lambda (o)
1024       (let* ((text (.text info))
1025              (info (clone info #:text '()))
1026              (info ((ast->info info) o))
1027              (jump-text (lambda (body-length)
1028                           (list (lambda (f g ta t d) (type body-length))))))
1029        (lambda (body-length)
1030          (clone info #:text
1031                 (append text
1032                         (.text info)
1033                         (if (null? test) '() (car test))
1034                         (jump-text body-length)))))))
1035   (lambda (o)
1036     (pmatch o
1037       ((lt ,a ,b) ((jump i386:Xjump-nc) o))
1038       ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1039       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1040       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1041       ((not _) ((jump i386:Xjump-z) o))
1042       ((and ,a ,b)
1043        (let* ((text (.text info))
1044               (info (clone info #:text '()))
1045
1046               (a-jump ((test->jump->info info) a))
1047               (a-text (.text (a-jump 0)))
1048               (a-length (length (text->list a-text)))
1049
1050               (b-jump ((test->jump->info info) b))
1051               (b-text (.text (b-jump 0)))
1052               (b-length (length (text->list b-text))))
1053
1054          (lambda (body-length)
1055            (clone info #:text
1056                   (append text
1057                           (.text (a-jump (+ b-length body-length)))
1058                           (.text (b-jump body-length)))))))
1059       ((or ,a ,b)
1060        (let* ((text (.text info))
1061               (info (clone info #:text '()))
1062
1063               (a-jump ((test->jump->info info) a))
1064               (a-text (.text (a-jump 0)))
1065               (a-length (length (text->list a-text)))
1066
1067               (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1068               (jump-length (length (text->list jump-text)))
1069
1070               (b-jump ((test->jump->info info) b))
1071               (b-text (.text (b-jump 0)))
1072               (b-length (length (text->list b-text)))
1073
1074               (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
1075
1076          (lambda (body-length)
1077            (clone info #:text
1078                   (append text
1079                           (.text (a-jump jump-length))
1080                           jump-text
1081                           (.text (b-jump body-length)))))))
1082
1083       ((array-ref . _) ((jump i386:jump-byte-z
1084                               (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1085
1086       ((de-ref _) ((jump i386:jump-byte-z
1087                          (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1088
1089       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1090        ((jump i386:Xjump-z
1091               (append
1092                ((ident->accu info) name)
1093                (list (lambda (f g ta t d) (i386:accu-zero?))))) o))
1094
1095       (_ ((jump i386:Xjump-z (list (lambda (f g ta t d) (i386:accu-zero?)))) o)))))
1096
1097 (define (cstring->number s)
1098   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1099         ((string-prefix? "0" s) (string->number s 8))
1100         (else (string->number s))))
1101
1102 (define (struct-field o)
1103   (pmatch o
1104     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1105                 (comp-declr-list (comp-declr (ident ,name))))
1106      (cons type name))
1107     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1108      (cons type name))
1109     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1110      (cons type name))
1111     ((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)))))))))
1112      (cons type name)) ;; FIXME function / int
1113     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1114      (cons type name)) ;; FIXME: ptr/char
1115     (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1116
1117 (define (ast->type o)
1118   (pmatch o
1119     ((fixed-type ,type)
1120      type)
1121     ((struct-ref (ident ,type))
1122      (list "struct" type))
1123     (_ (stderr "SKIP: type=~s\n" o)
1124        "int")))
1125
1126 (define i386:type-alist
1127   '(("char" . (builtin 1 #f))
1128     ("int" . (builtin 4 #f))))
1129
1130 (define (type->size info o)
1131   ;;(stderr  "types=~s\n" (.types info))
1132   ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
1133   (pmatch o
1134     ((decl-spec-list (type-spec (fixed-type ,type)))
1135      (type->size info type))
1136     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1137      (type->size info type))
1138     (_ (let ((type (assoc-ref (.types info) o)))
1139          (if type (cadr type)
1140              (begin
1141                (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1142                barf
1143                4))))))
1144
1145 (define (ident->decl info o)
1146   ;; (stderr "ident->decl o=~s\n" o)
1147   ;; (stderr "  types=~s\n" (.types info))
1148   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
1149   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
1150   (or (assoc-ref (.locals info) o)
1151       (assoc-ref (.globals info) o)
1152       (begin
1153         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1154         (assoc-ref (.functions info) o))))
1155
1156 (define (ident->type info o)
1157   (and=> (ident->decl info o) car))
1158
1159 (define (ident->pointer info o)
1160   (let ((local (assoc-ref (.locals info) o)))
1161     (if local (local:pointer local)
1162         (or (and=> (ident->decl info o) global:pointer) 0))))
1163
1164 (define (type->description info o)
1165   ;; (stderr  "type->description =~s\n" o)  
1166   ;; (stderr  "types=~s\n" (.types info))
1167   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
1168   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
1169   (pmatch o
1170     ((decl-spec-list (type-spec (fixed-type ,type)))
1171      (type->description info type))
1172     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1173      (type->description info type))
1174     (_ (caddr (assoc-ref (.types info) o)))))
1175
1176 (define (local? o) ;; formals < 0, locals > 0
1177   (positive? (local:id o)))
1178
1179 (define (ast->info info)
1180   (lambda (o)
1181     (let ((globals (.globals info))
1182           (locals (.locals info))
1183           (constants (.constants info))
1184           (text (.text info)))
1185       (define (add-local locals name type pointer)
1186         (let* ((id (1+ (length (filter local? (map cdr locals)))))
1187                (locals (cons (make-local name type pointer id) locals)))
1188           locals))
1189
1190       ;;(stderr "\n ast->info=~s\n" o)
1191       ;; (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)))
1192       ;; (stderr "  text=~a\n" text)
1193       ;; (stderr "   info=~a\n" info)
1194       ;; (stderr "   globals=~a\n" globals)
1195       (pmatch o
1196         (((trans-unit . _) . _)
1197          ((ast-list->info info)  o))
1198         ((trans-unit . ,elements)
1199          ((ast-list->info info) elements))
1200         ((fctn-defn . _) ((function->info info) o))
1201         ((comment . _) info)
1202         ((cpp-stmt (define (name ,name) (repl ,value)))
1203          info)
1204
1205         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1206          info)
1207
1208         ;; FIXME: expr-stmt wrapper?
1209         (trans-unit info)
1210         ((expr-stmt) info)
1211         ((assn-expr . ,assn-expr)
1212          ((ast->info info) `(expr-stmt ,o)))
1213
1214         ((d-sel . ,d-sel)
1215          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1216            expr))
1217
1218         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1219         
1220         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1221          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1222                                    (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1223              (let* ((globals (append globals (filter-map expr->global expr-list)))
1224                     (info (clone info #:globals globals))
1225                     (text-length (length text))
1226                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
1227                                  (if (null? expressions) info
1228                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1229                     (text (.text args-info))
1230                     (n (length expr-list)))
1231                (if (and (not (assoc-ref locals name))
1232                         (assoc-ref (.functions info) name))
1233                 (clone args-info #:text
1234                        (append text
1235                                (list (lambda (f g ta t d)
1236                                        (i386:call f g ta t d (+ t (function-offset name f)) n))))
1237                        #:globals globals)
1238                 (let* ((empty (clone info #:text '()))
1239                        (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1240                   (clone args-info #:text
1241                          (append text
1242                                  (.text accu)
1243                                  (list (lambda (f g ta t d)
1244                                          (i386:call-accu f g ta t d n))))
1245                          #:globals globals))))))
1246
1247         ;;((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))))
1248         ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1249          (let* ((globals (append globals (filter-map expr->global expr-list)))
1250                 (info (clone info #:globals globals))
1251                 (text-length (length text))
1252                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1253                              (if (null? expressions) info
1254                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1255                 (text (.text args-info))
1256                 (n (length expr-list))
1257                 (empty (clone info #:text '()))
1258                 (accu ((expr->accu empty) function)))
1259            (clone info #:text
1260                   (append text
1261                           (.text accu)
1262                           (list (lambda (f g ta t d)
1263                                   (i386:call-accu f g ta t d n))))
1264                   #:globals globals)))
1265
1266         ((if ,test ,body)
1267          (let* ((text-length (length text))
1268
1269                 (test-jump->info ((test->jump->info info) test))
1270                 (test+jump-info (test-jump->info 0))
1271                 (test-length (length (.text test+jump-info)))
1272
1273                 (body-info ((ast->info test+jump-info) body))
1274                 (text-body-info (.text body-info))
1275                 (body-text (list-tail text-body-info test-length))
1276                 (body-length (length (text->list body-text)))
1277
1278                 (text+test-text (.text (test-jump->info body-length)))
1279                 (test-text (list-tail text+test-text text-length)))
1280
1281            (clone info #:text
1282                   (append text
1283                           test-text
1284                           body-text)
1285                   #:globals (.globals body-info))))
1286
1287         ((if ,test ,then ,else)
1288          (let* ((text-length (length text))
1289
1290                 (test-jump->info ((test->jump->info info) test))
1291                 (test+jump-info (test-jump->info 0))
1292                 (test-length (length (.text test+jump-info)))
1293
1294                 (then-info ((ast->info test+jump-info) then))
1295                 (text-then-info (.text then-info))
1296                 (then-text (list-tail text-then-info test-length))
1297                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1298                 (then-jump-length (length (text->list then-jump-text)))
1299                 (then-length (+ (length (text->list then-text)) then-jump-length))
1300
1301                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1302                 (else-info ((ast->info then+jump-info) else))
1303                 (text-else-info (.text else-info))
1304                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1305                 (else-length (length (text->list else-text)))
1306
1307                 (text+test-text (.text (test-jump->info then-length)))
1308                 (test-text (list-tail text+test-text text-length))
1309                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1310
1311            (clone info #:text
1312                   (append text
1313                           test-text
1314                           then-text
1315                           then-jump-text
1316                           else-text)
1317                   #:globals (append (.globals then-info)
1318                                     (list-tail (.globals else-info) (length globals))))))
1319
1320         ((expr-stmt (cond-expr ,test ,then ,else))
1321          (let* ((text-length (length text))
1322
1323                 (test-jump->info ((test->jump->info info) test))
1324                 (test+jump-info (test-jump->info 0))
1325                 (test-length (length (.text test+jump-info)))
1326
1327                 (then-info ((ast->info test+jump-info) then))
1328                 (text-then-info (.text then-info))
1329                 (then-text (list-tail text-then-info test-length))
1330                 (then-length (length (text->list then-text)))
1331
1332                 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1333                 (jump-length (length (text->list jump-text)))
1334
1335                 (test+then+jump-info
1336                  (clone then-info
1337                         #:text (append (.text then-info) jump-text)))
1338
1339                 (else-info ((ast->info test+then+jump-info) else))
1340                 (text-else-info (.text else-info))
1341                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1342                 (else-length (length (text->list else-text)))
1343
1344                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1345                 (test-text (list-tail text+test-text text-length))
1346                 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1347
1348            (clone info #:text
1349                   (append text
1350                           test-text
1351                           then-text
1352                           jump-text
1353                           else-text)
1354                   #:globals (.globals else-info))))
1355
1356         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1357          (let* ((expr ((expr->accu info) expr))
1358                 (empty (clone info #:text '()))
1359                 (case-infos (map (case->jump-info empty) cases))
1360                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1361                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1362                               (if (null? cases) info
1363                                   (let ((c-j ((case->jump-info info) (car cases))))
1364                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1365            cases-info))
1366
1367         ((for ,init ,test ,step ,body)
1368          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1369
1370                 (info ((ast->info info) init))
1371
1372                 (init-text (.text info))
1373                 (init-locals (.locals info))
1374                 (info (clone info #:text '()))
1375
1376                 (body-info ((ast->info info) body))
1377                 (body-text (.text body-info))
1378                 (body-length (length (text->list body-text)))
1379
1380                 (step-info ((ast->info info) `(expr-stmt ,step)))
1381                 (step-text (.text step-info))
1382                 (step-length (length (text->list step-text)))
1383
1384                 (test-jump->info ((test->jump->info info) test))
1385                 (test+jump-info (test-jump->info 0))
1386                 (test-length (length (text->list (.text test+jump-info))))
1387
1388                 (skip-body-text (list (lambda (f g ta t d)
1389                                         (i386:Xjump (+ body-length step-length)))))
1390
1391                 (jump-text (list (lambda (f g ta t d)
1392                                    (i386:Xjump (- (+ body-length step-length test-length))))))
1393                 (jump-length (length (text->list jump-text)))
1394
1395                 (test-text (.text (test-jump->info jump-length))))
1396
1397            (clone info #:text
1398                   (append text
1399                           init-text
1400                           skip-body-text
1401                           body-text
1402                           step-text
1403                           test-text
1404                           jump-text)
1405                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1406                   #:locals locals)))
1407
1408         ;; FIXME: support break statement (see switch/case)
1409         ((while ,test ,body)
1410          (let* ((skip-info (lambda (body-length)
1411                              (clone info #:text (append text
1412                                                         (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
1413                 (text (.text (skip-info 0)))
1414                 (text-length (length text))
1415
1416                 (body-info (lambda (body-length)
1417                              ((ast->info (skip-info body-length)) body)))
1418                 (body-text (list-tail (.text (body-info 0)) text-length))
1419                 (body-length (length (text->list body-text)))
1420
1421                 (body-info (body-info body-length))
1422
1423                 (empty (clone info #:text '()))
1424                 (test-jump->info ((test->jump->info empty) test))
1425                 (test+jump-info (test-jump->info 0))
1426                 (test-length (length (text->list (.text test+jump-info))))
1427
1428                 (jump-text (list (lambda (f g ta t d)
1429                                    (i386:Xjump (- (+ body-length test-length))))))
1430                 (jump-length (length (text->list jump-text)))
1431
1432                 (test-text (.text (test-jump->info jump-length))))
1433            (clone info #:text
1434                   (append
1435                    (.text body-info)
1436                    test-text
1437                    jump-text)
1438                   #:globals (.globals body-info))))
1439
1440         ((do-while ,body ,test)
1441          (let* ((text-length (length text))
1442
1443                 (body-info ((ast->info info) body))
1444                 (body-text (list-tail (.text body-info) text-length))
1445                 (body-length (length (text->list body-text)))
1446
1447                 (empty (clone info #:text '()))
1448                 (test-jump->info ((test->jump->info empty) test))
1449                 (test+jump-info (test-jump->info 0))
1450                 (test-length (length (text->list (.text test+jump-info))))
1451
1452                 (jump-text (list (lambda (f g ta t d)
1453                                    (i386:Xjump (- (+ body-length test-length))))))
1454                 (jump-length (length (text->list jump-text)))
1455
1456                 (test-text (.text (test-jump->info jump-length))))
1457            (clone info #:text
1458                   (append
1459                    (.text body-info)
1460                    test-text
1461                    jump-text)
1462                   #:globals (.globals body-info))))
1463
1464         ((labeled-stmt (ident ,label) ,statement)
1465          (let ((info (clone info #:text (append text (list label)))))
1466            ((ast->info info) statement)))
1467
1468         ((goto (ident ,label))
1469          (let* ((jump (lambda (n) (i386:XXjump n)))
1470                 (offset (+ (length (jump 0)) (length (text->list text)))))
1471            (clone info #:text
1472                   (append text
1473                           (list (lambda (f g ta t d)
1474                                   (jump (- (label-offset (.function info) label f) offset))))))))
1475
1476         ;;; FIXME: only zero?!
1477         ((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:accu-zero?)))))))
1484
1485         ((p-expr (fixed ,value))
1486          (let ((value (cstring->number value)))
1487           (clone info #:text
1488                  (append text
1489                          (list (lambda (f g ta t d)
1490                                  (append
1491                                   (i386:value->accu value)
1492                                   (i386:accu-zero?))))))))
1493
1494         ((de-ref (p-expr (ident ,name)))
1495          (clone info #:text
1496                 (append text
1497                         ((ident->accu info) name)
1498                         (list (lambda (f g ta t d)
1499                                 (append
1500                                  (i386:byte-mem->accu)))))))
1501
1502         ((fctn-call . ,call)
1503          (let ((info ((ast->info info) `(expr-stmt ,o))))
1504            (clone info #:text
1505                   (append (.text info)
1506                           (list (lambda (f g ta t d)
1507                                   (i386:accu-zero?)))))))
1508
1509         ;; FIXME
1510         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1511         ((post-inc (p-expr (ident ,name)))
1512          (clone info #:text
1513                 (append text
1514                         ((ident->accu info) name)
1515                         ((ident-add info) name 1)
1516                         (list (lambda (f g ta t d)
1517                                 (append
1518                                  (i386:accu-zero?)))))))
1519         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1520         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1521         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1522         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1523
1524         ;; i++
1525         ((expr-stmt (post-inc (p-expr (ident ,name))))
1526          (clone info #:text (append text ((ident-add info) name 1))))
1527
1528         ;; ++i
1529         ((expr-stmt (pre-inc (p-expr (ident ,name))))
1530          (or (assoc-ref locals name) barf)
1531          (clone info #:text
1532                 (append text
1533                         ((ident-add info) name 1)
1534                         ((ident->accu info) name)
1535                         (list (lambda (f g ta t d)
1536                                 (append
1537                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1538                                  (i386:accu-zero?)))))))
1539
1540         ;; i--
1541         ((expr-stmt (post-dec (p-expr (ident ,name))))
1542          (or (assoc-ref locals name) barf)
1543          (clone info #:text
1544                 (append text
1545                         ((ident->accu info) name)
1546                         ((ident-add info) name -1)
1547                         (list (lambda (f g ta t d)
1548                                 (append
1549                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1550                                  (i386:accu-zero?)))))))
1551
1552         ;; --i
1553         ((expr-stmt (pre-dec (p-expr (ident ,name))))
1554          (or (assoc-ref locals name) barf)
1555          (clone info #:text
1556                 (append text
1557                         ((ident-add info) name -1)
1558                         ((ident->accu info) name)
1559                         (list (lambda (f g ta t d)
1560                                 (append
1561                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1562                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1563                                  (i386:accu-zero?)))))))
1564
1565         ((not ,expr)
1566          (let* ((test-info ((ast->info info) expr)))
1567            (clone info #:text
1568                   (append (.text test-info)
1569                           (list (lambda (f g ta t d)
1570                                   (append
1571                                    (i386:accu-not)
1572                                    (i386:accu-zero?)))))
1573                   #:globals (.globals test-info))))
1574
1575         ((eq ,a ,b)
1576          (let* ((base ((expr->base info) a))
1577                 (empty (clone base #:text '()))
1578                 (accu ((expr->accu empty) b)))
1579            (clone info #:text
1580                   (append text
1581                           (.text base)
1582                           (list (lambda (f g ta t d)
1583                                   (i386:push-base)))
1584                           (.text accu)
1585                           (i386:pop-accu)
1586                           (list (lambda (f g ta t d)
1587                                   (i386:sub-base)))))))
1588
1589         ((gt ,a ,b)
1590          (let* ((base ((expr->base info) a))
1591                 (empty (clone base #:text '()))
1592                 (accu ((expr->accu empty) b)))
1593            (clone info #:text
1594                   (append text
1595                           (.text base)
1596                           (list (lambda (f g ta t d)
1597                                   (i386:push-base)))
1598                           (.text accu)
1599                           (list (lambda (f g ta t d)
1600                                   (i386:pop-base)))
1601                           (list (lambda (f g ta t d)
1602                                   (i386:sub-base)))))))
1603
1604         ((ne ,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:pop-base)))
1616                           (list (lambda (f g ta t d)
1617                                   (append 
1618                                    (i386:sub-base)
1619                                    (i386:xor-zf))))))))
1620
1621         ((lt ,a ,b)
1622          (let* ((base ((expr->base info) a))
1623                 (empty (clone base #:text '()))
1624                 (accu ((expr->accu empty) b)))
1625            (clone info #:text
1626                   (append text
1627                           (.text base)
1628                           (list (lambda (f g ta t d)
1629                                   (i386:push-base)))
1630                           (.text accu)
1631                           (list (lambda (f g ta t d)
1632                                   (i386:base-sub)))))))
1633
1634         ;; TODO: byte dinges
1635         ((Xsub ,a ,b)
1636          (let* ((base ((expr->base info) a))
1637                 (empty (clone base #:text '()))
1638                 (accu ((expr->accu empty) b)))
1639            (clone info #:text
1640                   (append text
1641                           (.text base)
1642                           (list (lambda (f g ta t d)
1643                                   (i386:push-base)))
1644                           (.text accu)
1645                           (list (lambda (f g ta t d)
1646                                   (i386:pop-base)))
1647                           (list (lambda (f g ta t d)
1648                                   (i386:base-sub)))))))
1649
1650         ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1651          (clone info #:text
1652                 (append text
1653                         (list (lambda (f g ta t d)
1654                                 (append
1655                                  (i386:local->accu (local:id (assoc-ref locals a)))
1656                                  (i386:byte-mem->base)
1657                                  (i386:local->accu (local:id (assoc-ref locals b)))
1658                                  (i386:byte-mem->accu)
1659                                  (i386:byte-sub-base)))))))
1660
1661         ;; g_cells[0]
1662         ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
1663          (let* ((value (cstring->number value))
1664                 (type (ident->type info array))
1665                 (size (type->size info type)))
1666            (clone info #:text
1667                   (append text
1668                         ((ident->base info) array)
1669                         (list (lambda (f g ta t d)
1670                                 (append
1671                                  (i386:value->accu (* size index))
1672                                  (if (eq? size 1)
1673                                      (i386:byte-base-mem->accu)
1674                                      (i386:base-mem->accu)))))))))
1675         
1676         ;; g_cells[a]
1677         ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1678          (let* ((type (ident->type info array))
1679                 (size (type->size info type)))
1680            (clone info #:text
1681                   (append text
1682                           ((ident->base info) index)
1683                           (list (lambda (f g ta t d)
1684                                   (append
1685                                    (i386:base->accu)
1686                                    (if (< size 4) '()
1687                                        (begin
1688                                          (i386:accu+accu)
1689                                          (if (= size 12) (i386:accu+base) '())
1690                                          (i386:accu-shl 2))))))
1691                           ((ident->base info) array)
1692                           (list (lambda (f g ta t d)
1693                                  (if (eq? size 1)
1694                                      (i386:byte-base-mem->accu)
1695                                      (i386:base-mem->accu))))))))
1696         
1697         ((return ,expr)
1698          (let ((accu ((expr->accu info) expr)))
1699            (clone accu #:text
1700                   (append (.text accu) (list (lambda (f g ta t d) (i386:ret)))))))
1701
1702         ;; int i;
1703         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1704          (if (.function info)
1705              (clone info #:locals (add-local locals name type 0))
1706              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1707
1708         ;; int i = 0;
1709         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1710          (let ((value (cstring->number value)))
1711            (if (.function info)
1712                (let* ((locals (add-local locals name type 0))
1713                       (info (clone info #:locals locals)))
1714                  (clone info #:text
1715                         (append text
1716                                 ((value->ident info) name value))))
1717                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1718
1719         ;; char c = 'A';
1720         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1721          (if (not (.function info)) decl-barf0)
1722          (let* ((locals (add-local locals name type 0))
1723                 (info (clone info #:locals locals))
1724                 (value (char->integer (car (string->list value)))))
1725            (clone info #:text
1726                   (append text
1727                           ((value->ident info) name value)))))
1728
1729         ;; int i = -1;
1730         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1731          (if (not (.function info)) decl-barf1)
1732          (let* ((locals (add-local locals name type 0))
1733                 (info (clone info #:locals locals))
1734                 (value (- (cstring->number value))))
1735            (clone info #:text
1736                   (append text
1737                           ((value->ident info) name value)))))
1738
1739         ;; int i = argc;
1740         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1741          (if (not (.function info)) decl-barf2)
1742          (let* ((locals (add-local locals name type 0))
1743                 (info (clone info #:locals locals)))
1744            (clone info #:text
1745                   (append text
1746                           ((ident->accu info) local)
1747                           ((accu->ident info) name)))))
1748
1749         ;; char *p = "t.c";
1750         ;;(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"))))))
1751         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1752          (if (not (.function info)) decl-barf3)
1753          (let* ((locals (add-local locals name type 1))
1754                 (globals (append globals (list (string->global string))))
1755                 (info (clone info #:locals locals #:globals globals)))
1756            (clone info #:text
1757                   (append text
1758                           (list (lambda (f g ta t d)
1759                                   (append
1760                                    (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1761                           ((accu->ident info) name)))))
1762         
1763         ;; char arena[20000];
1764         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1765          (let ((type (ast->type type)))
1766            (if (.function info)
1767                TODO:decl-array 
1768                (let* ((globals (.globals info))
1769                       (count (cstring->number count))
1770                       (size (type->size info type))
1771                       ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1772                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1773                       (globals (append globals (list array))))
1774                  (clone info
1775                         #:globals globals)))))
1776
1777         ;;struct scm *g_cells = (struct scm*)arena;
1778         ((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)))))))
1779          ;;(stderr "0TYPE: ~s\n" type)
1780          (if (.function info)
1781              (let* ((locals (add-local locals name type 1))
1782                     (info (clone info #:locals locals)))
1783                (clone info #:text
1784                       (append text
1785                               ((ident->accu info) name)
1786                               ((accu->ident info) value)))) ;; FIXME: deref?
1787              (let* ((globals (append globals (list (ident->global name type 1 0))))
1788                     (info (clone info #:globals globals)))
1789                (clone info #:text
1790                       (append text
1791                               ((ident->accu info) name)
1792                               ((accu->ident info) value)))))) ;; FIXME: deref?
1793
1794         ;; SCM tmp;
1795         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1796          ;;(stderr  "1TYPE: ~s\n" type)
1797          (if (.function info)
1798              (clone info #:locals (add-local locals name type 0))
1799              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1800
1801         ;; SCM g_stack = 0;
1802         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1803          ;;(stderr  "2TYPE: ~s\n" type)
1804          (let ((value (cstring->number value)))
1805           (if (.function info)
1806               (let* ((locals (add-local locals name type 0))
1807                      (info (clone info #:locals locals)))
1808                 (clone info #:text
1809                        (append text
1810                                ((value->ident info) name value))))
1811               (let ((globals (append globals (list (ident->global name type 0 value)))))
1812                 (clone info #:globals globals)))))
1813
1814         ;; SCM g_stack = 0; // comment
1815         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1816          ((ast->info info) (list-head o (- (length o) 1))))
1817
1818         ;; SCM i = argc;
1819         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1820          ;;(stderr  "3TYPE: ~s\n" type)
1821          (if (.function info)
1822              (let* ((locals (add-local locals name type 0))
1823                     (info (clone info #:locals locals)))
1824                (clone info #:text
1825                       (append text
1826                               ((ident->accu info) local)
1827                               ((accu->ident info) name))))
1828              (let* ((globals (append globals (list (ident->global name type 0 0))))
1829                     (info (clone info #:globals globals)))
1830                (clone info #:text
1831                       (append text
1832                               ((ident->accu info) local)
1833                               ((accu->ident info) name))))))
1834
1835         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1836         ((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))))
1837          (let* ((locals (add-local locals name type 1))
1838                 (info (clone info #:locals locals))
1839                 (empty (clone info #:text '()))
1840                 (accu ((expr->accu empty) initzer)))
1841            (clone info
1842                   #:text
1843                   (append text
1844                           (.text accu)
1845                           ((accu->ident info) name)
1846                           (list (lambda (f g ta t d)
1847                                   (append
1848                                    ;;(i386:value->base t)
1849                                    ;;(i386:accu+base)
1850                                    (i386:value->base ta)
1851                                    (i386:accu+base)))))
1852                   #:locals locals)))
1853
1854         ;; char *p = (char*)g_cells;
1855         ((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)))))))
1856          ;;(stderr  "6TYPE: ~s\n" type)
1857          (if (.function info)
1858              (let* ((locals (add-local locals name type 1))
1859                     (info (clone info #:locals locals)))
1860                (clone info #:text
1861                       (append text
1862                               ((ident->accu info) value)
1863                               ((accu->ident info) name))))
1864              (let* ((globals (append globals (list (ident->global name type 1 0))))
1865                     (here (data-offset name globals))
1866                     (there (data-offset value globals)))
1867                (clone info
1868                       #:globals globals
1869                       #:init (append (.init info)
1870                                      (list (lambda (functions globals ta t d data)
1871                                              (append
1872                                               (list-head data here)
1873                                               ;;; FIXME: type
1874                                               ;;; char *x = arena;
1875                                               (int->bv32 (+ d (data-offset value globals)))
1876                                               ;;; char *y = x;
1877                                               ;;;(list-head (list-tail data there) 4)
1878                                               (list-tail data (+ here 4))))))))))
1879
1880         ;; char *p = g_cells;
1881         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1882          ;;(stderr  "7TYPE: ~s\n" type)
1883          (let ((type (decl->type type)))
1884            ;;(stderr "0DECL: ~s\n" type)
1885            (if (.function info)
1886                (let* ((locals (add-local locals name type  1))
1887                       (info (clone info #:locals locals)))
1888                  (clone info #:text
1889                         (append text
1890                                 ((ident->accu info) value)
1891                                 ((accu->ident info) name))))
1892                (let* ((globals (append globals (list (ident->global name type 1 0))))
1893                       (here (data-offset name globals)))
1894                  (clone info
1895                         #:globals globals
1896                         #:init (append (.init info)
1897                                        (list (lambda (functions globals ta t d data)
1898                                                (append
1899                                                 (list-head data here)
1900                                               ;;; FIXME: type
1901                                               ;;; char *x = arena;p
1902                                                 (int->bv32 (+ d (data-offset value globals)))
1903                                                 (list-tail data (+ here 4)))))))))))
1904
1905         ;; enum 
1906         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1907          (let ((type (enum->type name fields))
1908                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1909            (clone info
1910                   #:types (append (.types info) (list type))
1911                   #:constants (append constants (.constants info)))))
1912
1913         ;; struct
1914         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1915          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1916            ;;(stderr "type: ~a\n" type)
1917            (clone info #:types (append (.types info) (list type)))))
1918
1919         ;; *p++ = b;
1920         ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
1921          (when (not (equal? op "="))
1922            (stderr "OOOPS0.0: op=~s\n" op)
1923            barf)
1924          (let* ((empty (clone info #:text '()))
1925                 (base ((expr->base empty) b)))
1926            (clone info #:text
1927                   (append text
1928                           (.text base)
1929                           ((base->ident-address info) name)
1930                           ((ident-add info) name 1)))))
1931
1932         ;; *p-- = b;
1933         ((expr-stmt (assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b))
1934          (when (not (equal? op "="))
1935            (stderr "OOOPS0.0: op=~s\n" op)
1936            barf)
1937          (let* ((empty (clone info #:text '()))
1938                 (base ((expr->base empty) b)))
1939            (clone info #:text
1940                   (append text
1941                           (.text base)
1942                           ((base->ident-address info) name)
1943                           ((ident-add info) name -1)))))
1944
1945         ;; CAR (x) = 0
1946         ;; TYPE (x) = PAIR;
1947         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
1948          (when (not (equal? op "="))
1949            (stderr "OOOPS0: op=~s\n" op)
1950            barf)
1951          (let* ((empty (clone info #:text '()))
1952                 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
1953                 (base ((expr->base empty) b))
1954                 (type (list "struct" "scm")) ;; FIXME
1955                 (fields (type->description info type))
1956                 (size (type->size info type))
1957                 (field-size 4) ;; FIXME:4, not fixed
1958                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
1959            (clone info #:text (append text
1960                                       (.text expr)
1961                                       (.text base)
1962                                       (list (lambda (f g ta t d)
1963                                               ;;(i386:byte-base->accu-ref) ;; FIXME: size
1964                                               (i386:base->accu-address)
1965                                               ))))))
1966
1967
1968         ;; i = 0;
1969         ;; c = f ();
1970         ;; i = i + 48;
1971         ;; p = g_cell;
1972         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
1973          (when (and (not (equal? op "="))
1974                     (not (equal? op "+="))
1975                     (not (equal? op "-=")))
1976            (stderr "OOOPS1: op=~s\n" op)
1977            barf)
1978          (let* ((empty (clone info #:text '()))
1979                 (base ((expr->base empty) b)))
1980            (clone info #:text (append text
1981                                       (.text base)
1982                                       (if (equal? op "=") '()
1983                                           (append ((ident->accu info) name)
1984                                                   (list (lambda (f g ta t d)
1985                                                           (append
1986                                                            (if (equal? op "+=")
1987                                                                (i386:accu+base)
1988                                                                (i386:accu-base))
1989                                                            (i386:accu->base))))))
1990                                       ;;assign:
1991                                       ((base->ident info) name)))))
1992         
1993         ;; *p = 0;
1994         ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
1995          (when (not (equal? op "="))
1996            (stderr "OOOPS2: op=~s\n" op)
1997            barf)
1998          (let* ((empty (clone info #:text '()))
1999                 (base ((expr->base empty) b)))
2000            (clone info #:text (append text
2001                                       (.text base)
2002                                       ;;assign:
2003                                       ((base->ident-address info) array)))))
2004
2005         ;; g_cells[0] = 65;
2006         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2007          (when (not (equal? op "="))
2008            (stderr "OOOPS3: op=~s\n" op)
2009            barf)
2010          (let* ((index (cstring->number index))
2011                 (empty (clone info #:text '()))
2012                 (base ((expr->base empty) b))
2013                 (type (ident->type info array))
2014                 (fields (or (type->description info type) '()))  ;; FIXME: struct!
2015                 (size (type->size info type))
2016                 (count (length fields))
2017                 (field-size 4) ;; FIXME:4, not fixed
2018                 (ptr (ident->pointer info array)))
2019            (clone info #:text
2020                   (append text
2021                          (.text base)
2022                          (list (lambda (f g ta t d)
2023                                  (i386:push-base)))
2024                          (list (lambda (f g ta t d)
2025                                  (append
2026                                   (i386:value->base index)
2027                                   (i386:base->accu)
2028                                   (if (> count 1) (i386:accu+accu) '())
2029                                   (if (= count 3) (i386:accu+base) '())
2030                                   (i386:accu-shl 2))))
2031                          ((ident->base info) array)
2032                           (list (lambda (f g tav t d)
2033                                   (i386:accu+base)))
2034                          (list (lambda (f g ta t d)
2035                                  (i386:pop-base)))
2036                          (cond ((equal? array "g_functions") ;; FIXME
2037                                 (list (lambda (f g ta t d)
2038                                         (append
2039                                          (i386:base-address->accu-address)
2040                                          (i386:accu+n 4)
2041                                          (i386:base+n 4)
2042                                          (i386:base-address->accu-address)
2043                                          (i386:accu+n 4)
2044                                          (i386:base+n 4)
2045                                          (i386:base-address->accu-address)))))
2046                                (else (list (lambda (f g ta t d)
2047                                              (i386:base->accu-address)))))))))
2048
2049         ;; g_cells[i] = c;
2050         ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2051          ;;(stderr "pointer_cells4[]: ~s\n" array)
2052          (when (not (equal? op "="))
2053            (stderr "OOOPS4: op=~s\n" op)
2054            barf)
2055          (let* ((empty (clone info #:text '()))
2056                 (base ((expr->base empty) b))
2057                 (type (ident->type info array))
2058                 (fields (or (type->description info type) '()))  ;; FIXME: struct!
2059                 (size (type->size info type))
2060                 (count (length fields))
2061                 (field-size 4) ;; FIXME:4, not fixed
2062                 (ptr (ident->pointer info array)))
2063            (clone info #:text
2064                   (append text
2065                           (.text base)
2066                           (list (lambda (f g ta t d)
2067                                   (i386:push-base)))
2068                           ((ident->base info) index)
2069                           (list (lambda (f g ta t d)
2070                                   (append
2071                                    (i386:base->accu)
2072                                    (if (> count 1) (i386:accu+accu) '())
2073                                    (if (= count 3) (i386:accu+base) '())
2074                                    (i386:accu-shl 2))))
2075                           ((ident->base info) array)
2076                           (list (lambda (f g ta t d)
2077                                   (i386:accu+base)))
2078                          (list (lambda (f g ta t d)
2079                                  (i386:pop-base)))
2080                          (cond ((equal? array "g_functions") ;; FIXME
2081                                 (list (lambda (f g ta t d)
2082                                         (append
2083                                          (i386:base-address->accu-address)
2084                                          (i386:accu+n 4)
2085                                          (i386:base+n 4)
2086                                          (i386:base-address->accu-address)
2087                                          (i386:accu+n 4)
2088                                          (i386:base+n 4)
2089                                          (i386:base-address->accu-address)))))
2090                                (else (list (lambda (f g ta t d)
2091                                              (i386:base->accu-address)))))))))
2092
2093         ;; g_functions[g_function++] = g_foo;
2094         ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
2095          (when (not (equal? op "="))
2096            (stderr "OOOPS5: op=~s\n" op)
2097            barf)
2098          (let* ((empty (clone info #:text '()))
2099                 (base ((expr->base empty) b))
2100                 (type (ident->type info array))
2101                 (fields (or (type->description info type) '()))  ;; FIXME: struct!
2102                 (size (type->size info type))
2103                 (count (length fields))
2104                 (field-size 4) ;; FIXME:4, not fixed
2105                 (ptr (ident->pointer info array)))
2106            (clone info #:text
2107                   (append text
2108                           (.text base)
2109                           (list (lambda (f g ta t d)
2110                                   (i386:push-base)))
2111                           ((ident->base info) index)
2112                           (list (lambda (f g ta t d)
2113                                   (append
2114                                    (i386:base->accu)
2115                                    (if (> count 1) (i386:accu+accu) '())
2116                                    (if (= count 3) (i386:accu+base) '())
2117                                    (i386:accu-shl 2))))
2118                           ((ident->base info) array)
2119                           (list (lambda (f g ta t d)
2120                                   (i386:accu+base)))
2121                          (list (lambda (f g ta t d)
2122                                  (i386:pop-base)))
2123                          ;; FIXME
2124                          (cond ((equal? array "g_functions") ;; FIXME
2125                                 (list (lambda (f g ta t d)
2126                                         (append
2127                                          (i386:base-address->accu-address)
2128                                          (i386:accu+n 4)
2129                                          (i386:base+n 4)
2130                                          (i386:base-address->accu-address)
2131                                          (i386:accu+n 4)
2132                                          (i386:base+n 4)
2133                                          (i386:base-address->accu-address)))))
2134                                (else (list (lambda (f g ta t d)
2135                                              (i386:base->accu-address)))))
2136                          ((ident-add info) index 1)))))
2137
2138         ;; DECL
2139         ;;
2140         ;; struct f = {...};
2141         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2142          (let* ((type (decl->type type))
2143                 ;;(foo (stderr "1DECL: ~s\n" type))
2144                 (fields (type->description info type))
2145                 (size (type->size info type))
2146                 (field-size 4))  ;; FIXME:4, not fixed
2147            ;;(stderr  "7TYPE: ~s\n" type)
2148            (if (.function info)
2149                (let* ((globals (append globals (filter-map initzer->global initzers)))
2150                       (locals (let loop ((fields (cdr fields)) (locals locals))
2151                                 (if (null? fields) locals
2152                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2153                       (locals (add-local locals name type -1))
2154                       (info (clone info #:locals locals #:globals globals))
2155                       (empty (clone info #:text '())))
2156                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2157                    (if (null? fields) info
2158                        (let ((offset (* field-size (car fields)))
2159                              (initzer (car initzers)))
2160                          (loop (cdr fields) (cdr initzers)
2161                                (clone info #:text
2162                                       (append
2163                                        (.text info)
2164                                        ((ident->accu info) name)
2165                                        (list (lambda (f g ta t d)
2166                                                (append
2167                                                 (i386:accu->base))))
2168                                        (.text ((expr->accu empty) initzer))
2169                                        (list (lambda (f g ta t d)
2170                                                (i386:accu->base-address+n offset))))))))))
2171                (let* ((globals (append globals (filter-map initzer->global initzers)))
2172                       (global (make-global name type -1 (string->list (make-string size #\nul))))
2173                       (globals (append globals (list global)))
2174                       (here (data-offset name globals))
2175                       (info (clone info #:globals globals))
2176                       (field-size 4))
2177                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2178                    (if (null? fields) info
2179                        (let ((offset (* field-size (car fields)))
2180                              (initzer (car initzers)))
2181                          (loop (cdr fields) (cdr initzers)
2182                                (clone info #:init
2183                                       (append
2184                                        (.init info)
2185                                        (list (lambda (functions globals ta t d data)
2186                                                (append
2187                                                 (list-head data (+ here offset))
2188                                                 (initzer->data info functions globals ta t d (car initzers))
2189                                                 (list-tail data (+ here offset field-size)))))))))))))))
2190
2191
2192         ;;char cc = g_cells[c].cdr;  ==> generic?
2193         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2194          (let ((type (decl->type type)))
2195            (if (.function info)
2196                (let* ((locals (add-local locals name type 0))
2197                       (info (clone info #:locals locals)))
2198                  (clone info #:text
2199                         (append (.text ((expr->accu info) initzer))
2200                                 ((accu->ident info) name))))
2201                (let* ((globals (append globals (list (ident->global name type 1 0))))
2202                       (here (data-offset name globals)))
2203                  (clone info
2204                         #:globals globals
2205                         #:init (append (.init info)
2206                                        (list (lambda (functions globals ta t d data)
2207                                                (append
2208                                                 (list-head data here)
2209                                                 (initzer->data info functions globals ta t d initzer)
2210                                                 (list-tail data (+ here 4)))))))))))
2211
2212
2213         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2214          info)
2215
2216         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
2217          info)
2218
2219         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2220          (let ((types (.types info)))
2221            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
2222
2223         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2224          (format (current-error-port) "SKIP: typedef=~s\n" o)
2225          info)
2226
2227         ((decl (@ ,at))
2228          (format (current-error-port) "SKIP: at=~s\n" o)
2229          info)
2230
2231         ((decl . _)
2232          (format (current-error-port) "SKIP: decl statement=~s\n" o)
2233          barf
2234          info)
2235
2236         (_
2237          (format (current-error-port) "SKIP: statement=~s\n" o)
2238          barf
2239          info)))))
2240
2241 (define (initzer->data info functions globals ta t d o)
2242   (pmatch o
2243     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2244     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2245     ((initzer (ref-to (p-expr (ident ,name))))
2246      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2247      (int->bv32 (+ ta (function-offset name functions))))
2248     ((initzer (p-expr (ident ,name)))
2249      (let ((value (assoc-ref (.constants info) name)))
2250        (int->bv32 value)))
2251     ((initzer (p-expr (string ,string)))
2252      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2253     (_ (stderr "initzer->data:SKIP: ~s\n" o)
2254        barf
2255      (int->bv32 0))))
2256
2257 (define (info->exe info)
2258   (display "dumping elf\n" (current-error-port))
2259   (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2260
2261 (define (.formals o)
2262   (pmatch o
2263     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2264     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2265     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2266        barf)))
2267
2268 (define (formal->text n)
2269   (lambda (o i)
2270     ;;(i386:formal i n)
2271     '()
2272     ))
2273
2274 (define (formals->text o)
2275   (pmatch o
2276     ((param-list . ,formals)
2277      (let ((n (length formals)))
2278        (list (lambda (f g ta t d)
2279                (append
2280                 (i386:function-preamble)
2281                 (append-map (formal->text n) formals (iota n))
2282                 (i386:function-locals))))))
2283     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2284        barf)))
2285
2286 (define (formal:ptr o)
2287   (pmatch o
2288     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2289      1)
2290     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2291      0)
2292     (_
2293      (stderr "formal:ptr[~a] => 0\n" o)
2294      0)))
2295
2296 (define (formals->locals o)
2297   (pmatch o
2298     ((param-list . ,formals)
2299      (let ((n (length formals)))
2300        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2301     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2302        barf)))
2303
2304 (define (function->info info)
2305   (lambda (o)
2306     ;;(stderr "\n")
2307     ;;(stderr "formals=~a\n" (.formals o))
2308     (let* ((name (.name o))
2309            (text (formals->text (.formals o)))
2310            (locals (formals->locals (.formals o))))
2311       (format (current-error-port) "compiling ~a\n" name)
2312       ;;(stderr "locals=~a\n" locals)
2313       (let loop ((statements (.statements o))
2314                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2315         (if (null? statements) (clone info
2316                                       #:function #f
2317                                       #:functions (append (.functions info) (list (cons name (.text info)))))
2318             (let* ((statement (car statements)))
2319               (loop (cdr statements)
2320                     ((ast->info info) (car statements)))))))))
2321
2322 (define (ast-list->info info)
2323   (lambda (elements)
2324     (let loop ((elements elements) (info info))
2325       (if (null? elements) info
2326           (loop (cdr elements) ((ast->info info) (car elements)))))))
2327
2328 (define _start
2329   (let* ((argc-argv
2330           (string-append ".byte"
2331                          " 0x89 0xe8"      ; mov    %ebp,%eax
2332                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
2333                          " 0x50"           ; push   %eax
2334                          " 0x89 0xe8"      ; mov    %ebp,%eax
2335                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
2336                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
2337                          " 0x50"           ; push   %eax
2338                          ))
2339          (ast (with-input-from-string
2340                   
2341                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
2342                 parse-c99)))
2343     ast))
2344
2345 (define strlen
2346   (let* ((ast (with-input-from-string
2347                   "
2348 int
2349 strlen (char const* s)
2350 {
2351   int i = 0;
2352   while (s[i]) i++;
2353   return i;
2354 }
2355 "
2356 ;;paredit:"
2357                 parse-c99)))
2358     ast))
2359
2360 (define getchar
2361   (let* ((ast (with-input-from-string
2362                   "
2363 int g_stdin;
2364 int
2365 getchar ()
2366 {
2367   char c;
2368   int r = read (g_stdin, &c, 1);
2369   //int r = read (0, &c, 1);
2370   if (r < 1) return -1;
2371   return c;
2372 }
2373 "
2374 ;;paredit:"
2375                 parse-c99)))
2376     ast))
2377
2378 (define putchar
2379   (let* ((ast (with-input-from-string
2380                   "
2381 int
2382 putchar (int c)
2383 {
2384   //write (STDOUT, s, strlen (s));
2385   //int i = write (STDOUT, s, strlen (s));
2386   write (1, (char*)&c, 1);
2387   return 0;
2388 }
2389 "
2390 ;;paredit:"
2391                 parse-c99)))
2392     ast))
2393
2394 (define eputs
2395   (let* ((ast (with-input-from-string
2396                   "
2397 int
2398 eputs (char const* s)
2399 {
2400   //write (STDERR, s, strlen (s));
2401   //write (2, s, strlen (s));
2402   int i = strlen (s);
2403   write (2, s, i);
2404   return 0;
2405 }
2406 "
2407 ;;paredit:"
2408                 parse-c99)))
2409     ast))
2410
2411 (define fputs
2412   (let* ((ast (with-input-from-string
2413                   "
2414 int
2415 fputs (char const* s, int fd)
2416 {
2417   int i = strlen (s);
2418   write (fd, s, i);
2419   return 0;
2420 }
2421 "
2422 ;;paredit:"
2423                 parse-c99)))
2424     ast))
2425
2426 (define puts
2427   (let* ((ast (with-input-from-string
2428                   "
2429 int
2430 puts (char const* s)
2431 {
2432   //write (STDOUT, s, strlen (s));
2433   //int i = write (STDOUT, s, strlen (s));
2434   int i = strlen (s);
2435   write (1, s, i);
2436   return 0;
2437 }
2438 "
2439 ;;paredit:"
2440                 parse-c99)))
2441     ast))
2442
2443 (define strcmp
2444   (let* ((ast (with-input-from-string
2445                   "
2446 int
2447 strcmp (char const* a, char const* b)
2448 {
2449   while (*a && *b && *a == *b) 
2450     {
2451       a++;b++;
2452     }
2453   return *a - *b;
2454 }
2455 "
2456 ;;paredit:"
2457                 parse-c99)))
2458     ast))
2459
2460 (define i386:libc
2461   (list
2462    (cons "exit" (list i386:exit))
2463    (cons "open" (list i386:open))
2464    (cons "read" (list i386:read))
2465    (cons "write" (list i386:write))))
2466
2467 (define libc
2468   (list
2469    strlen
2470    getchar
2471    putchar
2472    eputs
2473    fputs
2474    puts
2475    strcmp))
2476
2477 (define (compile)
2478   (let* ((ast (mescc))
2479          (info (make <info>
2480                  #:functions i386:libc
2481                  #:types i386:type-alist))
2482          (ast (append libc ast))
2483          (info ((ast->info info) ast))
2484          (info ((ast->info info) _start)))
2485     (info->exe info)))