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