mescc: Refactor binary operators.
[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     (wrap-as (i386:push-local (local:id o)))))
196
197 (define (push-global-address globals)
198   (lambda (o)
199     (list
200      (lambda (f g ta t d)
201        (i386:push-global-address (+ (data-offset o g) d))))))
202
203 (define (push-local-address locals)
204   (lambda (o)
205     (wrap-as (i386:push-local-address (local:id o)))))
206
207 (define push-global-de-ref push-global)
208
209 (define (push-local-de-ref locals)
210   (lambda (o)
211     (wrap-as (i386:push-local-de-ref (local:id o)))))
212
213 (define (string->global string)
214   (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
215
216 (define (ident->global name type pointer value)
217   (make-global name type pointer (int->bv32 value)))
218
219 (define (make-local name type pointer id)
220   (cons name (list type pointer id)))
221 (define local:type car)
222 (define local:pointer cadr)
223 (define local:id caddr)
224
225 (define (push-ident info)
226   (lambda (o)
227     (let ((local (assoc-ref (.locals info) o)))
228       (if local ((push-local (.locals info)) local)
229           (let ((global (assoc-ref (.globals info) o)))
230             (if global
231                 ((push-global (.globals info)) o) ;; FIXME: char*/int
232                 (let ((constant (assoc-ref (.constants info) o)))
233                   (if constant
234                       (wrap-as (append (i386:value->accu constant)
235                                        (i386:push-accu)))
236                       TODO:push-function))))))))
237
238 (define (push-ident-address info)
239   (lambda (o)
240     (let ((local (assoc-ref (.locals info) o)))
241       (if local ((push-local-address (.locals info)) local)
242           ((push-global-address (.globals info)) o)))))
243
244 (define (push-ident-de-ref info)
245   (lambda (o)
246     (let ((local (assoc-ref (.locals info) o)))
247       (if local ((push-local-de-ref (.locals info)) local)
248           ((push-global-de-ref (.globals info)) o)))))
249
250 (define (expr->arg info)
251   (lambda (o)
252     (let ((info ((expr->accu info) o)))
253       (append-text info (wrap-as (i386:push-accu))))))
254
255 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
256   (lambda (o)
257     (let ((text (.text info)))
258       ;;(stderr  "expr->arg o=~s\n" o)
259       (pmatch o
260
261         ((p-expr (string ,string))
262          (append-text info ((push-global-address info) (add-s:-prefix string))))
263
264         ((p-expr (ident ,name))
265          (append-text info ((push-ident info) name)))
266
267         ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
268                           (abs-declr (pointer)))
269                ,cast)
270          ((expr->arg info) cast))
271
272         ((de-ref (p-expr (ident ,name)))
273          (append-text info ((push-ident-de-ref info) name)))
274
275         ((ref-to (p-expr (ident ,name)))
276          (append-text info ((push-ident-address info) name)))
277
278         (_ (append-text ((expr->accu info) o)
279                         (wrap-as (i386:push-accu))))))))
280
281 ;; FIXME: see ident->base
282 (define (ident->accu info)
283   (lambda (o)
284     (let ((local (assoc-ref (.locals info) o))
285           (global (assoc-ref (.globals info) o))
286           (constant (assoc-ref (.constants info) o)))
287       ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
288       ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
289       ;; (stderr "globals: ~a\n" (.globals info))
290       ;; (if (and (not global) (not (local:id local)))
291       ;;     (stderr "globals: ~a\n" (map car (.globals info))))
292       (if local
293           (let* ((ptr (local:pointer local))
294                  (type (ident->type info o))
295                  (size (and type (type->size info type))))
296             ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
297             ;;(stderr "type: ~s\n" type)
298             ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
299             ;;(stderr "locals: ~s\n" locals)
300             (case ptr
301               ((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
302               ((1) (wrap-as (i386:local->accu (local:id local))))
303               (else
304                (wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
305                             (i386:local->accu (local:id local)))))))
306           (if global
307               (let ((ptr (ident->pointer info o)))
308                 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
309                 (case ptr
310                   ((-1) (list (lambda (f g ta t d)
311                                 (i386:global->accu (+ (data-offset o g) d)))))
312                   (else (list (lambda (f g ta t d)
313                                 (i386:global-address->accu (+ (data-offset o g) d)))))))
314               (if constant (wrap-as (i386:value->accu constant))
315                   (list (lambda (f g ta t d)
316                           (i386:global->accu (+ ta (function-offset o f)))))))))))
317
318 (define (value->accu v)
319   (wrap-as (i386:value->accu v)))
320
321 (define (accu->ident info)
322   (lambda (o)
323     (let ((local (assoc-ref (.locals info) o)))
324       (if local (wrap-as (i386:accu->local (local:id local)))
325           (list (lambda (f g ta t d)
326                   (i386:accu->global (+ (data-offset o g) d))))))))
327
328 (define (base->ident info)
329   (lambda (o)
330     (let ((local (assoc-ref (.locals info) o)))
331       (if local (wrap-as (i386:base->local (local:id local)))
332           (list (lambda (f g ta t d)
333                   (i386:base->global (+ (data-offset o g) d))))))))
334
335 (define (base->ident-address info)
336   (lambda (o)
337     (let ((local (assoc-ref (.locals info) o)))
338       (if local (wrap-as (append (i386:local->accu (local:id local))
339                                  (i386:byte-base->accu-address)))
340           TODO:base->ident-address-global))))
341
342 (define (value->ident info)
343   (lambda (o value)
344     (let ((local (assoc-ref (.locals info) o)))
345       (if local (wrap-as (i386:value->local (local:id local) value))
346           (list (lambda (f g ta t d)
347                   (i386:value->global (+ (data-offset o g) d) value)))))))
348
349 (define (ident-add info)
350   (lambda (o n)
351     (let ((local (assoc-ref (.locals info) o)))
352       (if local (wrap-as (i386:local-add (local:id local) n))
353           (list (lambda (f g ta t d)
354                   (i386:global-add (+ (data-offset o g) d) n)))))))
355
356 ;; FIXME: see ident->accu
357 (define (ident->base info)
358   (lambda (o)
359     (let ((local (assoc-ref (.locals info) o)))
360       ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
361       (if local
362           (let* ((ptr (local:pointer local))
363                  (type (ident->type info o))
364                  (size (and type (type->size info type))))
365             (case ptr
366               ((-1) (wrap-as (i386:local-ptr->base (local:id local))))
367               ((1) (wrap-as (i386:local->base (local:id local))))
368               (else
369                (wrap-as (if (= size 1) (i386:byte-local->base (local:id local))
370                             (i386:local->base (local:id local)))))))
371           (let ((global (assoc-ref (.globals info) o) ))
372             (if global
373                 (let ((ptr (ident->pointer info o)))
374                   ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
375                   (case ptr
376                     ((-1) (list (lambda (f g ta t d)
377                                   (i386:global->base (+ (data-offset o g) d)))))
378                     (else (list (lambda (f g ta t d)
379                                   (i386:global-address->base (+ (data-offset o g) d)))))))
380                 (let ((constant (assoc-ref (.constants info) o)))
381                   (if constant (wrap-as (i386:value->base constant))
382                       (list (lambda (f g ta t d)
383                               (i386:global->base (+ ta (function-offset o f)))))))))))))
384
385 (define (expr->accu info)
386   (lambda (o)
387     (let ((locals (.locals info))
388           (constants (.constants info))
389           (text (.text info))
390           (globals (.globals info)))
391       (define (add-local locals name type pointer)
392         (let* ((id (1+ (length (filter local? (map cdr locals)))))
393                (locals (cons (make-local name type pointer id) locals)))
394           locals))
395       ;; (stderr "expr->accu o=~a\n" o)
396       (pmatch o
397         ((p-expr (string ,string))
398          (append-text info (list (lambda (f g ta t d)
399                                    (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))
400         ((p-expr (fixed ,value))
401          (append-text info (value->accu (cstring->number value))))
402         ((p-expr (ident ,name))
403          (append-text info ((ident->accu info) name)))
404
405         ((initzer ,initzer) ((expr->accu info) initzer))
406         ((ref-to (p-expr (ident ,name)))
407          (append-text info ((ident->accu info) name)))
408
409         ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
410          (let* ((type (list "struct" name))
411                 (fields (or (type->description info type) '()))
412                 (size (type->size info type)))
413            (append-text info (wrap-as (i386:value->accu size)))))
414         
415         ;; c+p expr->arg
416         ;; g_cells[<expr>]
417         ((array-ref ,index (p-expr (ident ,array)))
418          (let* ((info ((expr->accu info) index))
419                 (type (ident->type info array))
420                 (size (type->size info type)))
421            (append-text info (append
422                               ;; immediate: (i386:value->accu (* size index))
423                               ;; * size cells: * length * 4 = * 12
424                               (wrap-as (append (i386:accu->base)
425                                                (if (eq? size 1) '()
426                                                    (append
427                                                     (if (> size 4) (i386:accu+accu) '())
428                                                     (if (> size 8) (i386:accu+base) '())
429                                                     (i386:accu-shl 2)))))
430                               ((ident->base info) array)
431                               (wrap-as (append (case size
432                                                  ((1) (i386:byte-base-mem->accu))
433                                                  ((4) (i386:base-mem->accu))
434                                                  (else (i386:accu+base)))))))))
435
436         ;; f.field
437         ((d-sel (ident ,field) (p-expr (ident ,array)))
438          (let* ((type (ident->type info array))
439                 (fields (type->description info type))
440                 (field-size 4) ;; FIXME:4, not fixed
441                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
442                 (text (.text info)))
443            (append-text info (append ((ident->accu info) array)
444                                      (wrap-as (i386:mem+n->accu offset))))))
445
446         ;; g_cells[10].type
447         ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
448          (let* ((type (ident->type info array))
449                 (fields (or (type->description info type) '()))
450                 (size (type->size info type))
451                 (count (length fields))
452                 (field-size 4) ;; FIXME:4, not fixed
453                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
454                 (index (cstring->number index))
455                 (text (.text info)))
456            (append-text info (append
457                               (wrap-as (append (i386:value->base index)
458                                                (i386:base->accu)
459                                                (if (<= count 1) '() (i386:accu+accu))
460                                                (if (<= count 2) '() (i386:accu+base))
461                                                (i386:accu-shl 2)))
462                               ((ident->base info) array)
463                               (wrap-as (i386:base-mem+n->accu offset))))))
464         
465         ;; g_cells[x].type
466         ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
467          (let* ((type (ident->type info array))
468                 (fields (or (type->description info type) '()))
469                 (size (type->size info type))
470                 (count (length fields))
471                 (field-size 4) ;; FIXME:4, not fixed
472                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
473                 (text (.text info)))
474            (append-text info (append ((ident->base info) index)
475                                      (wrap-as (append (i386:base->accu)
476                                                       (if (<= count 1) '() (i386:accu+accu))
477                                                       (if (<= count 2) '() (i386:accu+base))
478                                                       (i386:accu-shl 2)))
479                                      ((ident->base info) array)
480                                      (wrap-as (i386:base-mem+n->accu offset))))))
481
482         ;; g_functions[g_cells[fn].cdr].arity
483         ;; INDEX0: g_cells[fn].cdr
484
485         ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
486         ;;((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)))))
487         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
488          (let* ((empty (clone info #:text '()))
489                 (index ((expr->accu empty) index))
490                 (type (ident->type info array))
491                 (fields (or (type->description info type) '()))
492                 (size (type->size info type))
493                 (count (length fields))
494                 (field-size 4) ;; FIXME:4, not fixed
495                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
496                           (begin
497                             (stderr "no field:~a\n" field)
498                             '())))
499                 (offset (* field-size (1- (length rest))))
500                 (text (.text info)))
501            (append-text info (append (.text index)
502                                      (wrap-as (append (i386:accu->base)
503                                                       (if (<= count 1) '() (i386:accu+accu))
504                                                       (if (<= count 2) '() (i386:accu+base))
505                                                       (i386:accu-shl 2)))
506                                      ((ident->base info) array)
507                                      (wrap-as (i386:base-mem+n->accu offset))))))
508         
509         ;;; FIXME: FROM INFO ...only zero?!
510         ((p-expr (fixed ,value))
511          (let ((value (cstring->number value)))
512            (append-text info (wrap-as (i386:value->accu value)))))
513
514         ((p-expr (char ,char))
515          (let ((char (char->integer (car (string->list char)))))
516            (append-text info (wrap-as (i386:value->accu char)))))
517
518         ((p-expr (ident ,name))
519          (append-text info ((ident->accu info) name)))
520
521         ((de-ref (p-expr (ident ,name)))
522          (let* ((type (ident->type info name))
523                 (size (and type (type->size info type))))
524            (append-text info (append ((ident->accu info) name)
525                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
526                                                   (i386:mem->accu)))))))
527
528         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
529          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
530                                    (append-text info (wrap-as (asm->hex arg0))))
531              (let* ((globals (append globals (filter-map expr->global expr-list)))
532                     (info (clone info #:globals globals))
533                     (text-length (length text))
534                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
535                                  (if (null? expressions) info
536                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
537                     (text (.text args-info))
538                     (n (length expr-list)))
539                (if (and (not (assoc-ref locals name))
540                         (assoc-ref (.functions info) name))
541                    (clone args-info #:text
542                           (append text
543                                   (list (lambda (f g ta t d)
544                                           (i386:call f g ta t d (+ t (function-offset name f)) n))))
545                           #:globals globals)
546                    (let* ((empty (clone info #:text '()))
547                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
548                      (clone args-info #:text
549                             (append text
550                                     (.text accu)
551                                     (list (lambda (f g ta t d)
552                                             (i386:call-accu f g ta t d n))))
553                             #:globals globals))))))
554
555         ((fctn-call ,function (expr-list . ,expr-list))
556          (let* ((globals (append globals (filter-map expr->global expr-list)))
557                 (info (clone info #:globals globals))
558                 (text-length (length text))
559                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
560                              (if (null? expressions) info
561                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
562                 (text (.text args-info))
563                 (n (length expr-list))
564                 (empty (clone info #:text '()))
565                 (accu ((expr->accu empty) function)))
566            (clone info #:text
567                   (append text
568                           (.text accu)
569                           (list (lambda (f g ta t d)
570                                   (i386:call-accu f g ta t d n))))
571                   #:globals globals)))
572
573         ((cond-expr . ,cond-expr)
574          ((ast->info info) `(expr-stmt ,o)))
575
576         ((post-inc (p-expr (ident ,name)))
577          (append-text info (append ((ident->accu info) name)
578                                    ((ident-add info) name 1))))
579
580         ((post-dec (p-expr (ident ,name)))
581          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
582          (append-text info (append ((ident->accu info) name)
583                                    ((ident-add info) name -1))))
584
585         ((pre-inc (p-expr (ident ,name)))
586          (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
587          (append-text info (append ((ident-add info) name 1)
588                                    ((ident->accu info) name))))
589
590         ((pre-dec (p-expr (ident ,name)))
591          (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
592          (append-text info (append ((ident-add info) name -1)
593                                    ((ident->accu info) name))))
594
595         ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
596         ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
597         ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
598         ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
599         ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
600         ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
601         ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
602         ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
603
604         ((not ,expr)
605          (let* ((test-info ((ast->info info) expr)))
606            (clone info #:text
607                   (append (.text test-info)
608                           (wrap-as (i386:accu-not)))
609                   #:globals (.globals test-info))))
610
611         ((neg (p-expr (fixed ,value)))
612          (append-text info (value->accu (- (cstring->number value)))))
613
614         ((neg (p-expr (ident ,name)))
615          (append-text info (append ((ident->base info) name)
616                                    (wrap-as (i386:value->accu 0))
617                                    (wrap-as (i386:sub-base)))))
618
619         ((eq ,a ,b) ((binop->accu info) a b (i386:sub-base)))
620         ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
621         ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
622         ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base)
623                                                     (i386:xor-zf))))
624         ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
625         ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
626
627         ;;((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"))))))
628         ((cast ,cast ,o)
629          ((expr->accu info) o))
630
631         ;; *p++ = b;
632         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
633          (when (not (equal? op "="))
634            (stderr "OOOPS0.0: op=~s\n" op)
635            barf)
636          (let* ((empty (clone info #:text '()))
637                 (base ((expr->base empty) b)))
638            (append-text info (append (.text base)
639                                      ((base->ident-address info) name)
640                                      ((ident->accu info) name)
641                                      ((ident-add info) name 1)))))
642
643         ;; *p-- = b;
644         ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
645          (when (not (equal? op "="))
646            (stderr "OOOPS0.0: op=~s\n" op)
647            barf)
648          (let* ((empty (clone info #:text '()))
649                 (base ((expr->base empty) b)))
650            (append-text info (append (.text base)
651                                      ((base->ident-address info) name)
652                                      ((ident->accu info) name)
653                                      ((ident-add info) name -1)))))
654
655         ;; CAR (x) = 0
656         ;; TYPE (x) = PAIR;
657         ((assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b)
658          (when (not (equal? op "="))
659            (stderr "OOOPS0: op=~s\n" op)
660            barf)
661          (let* ((empty (clone info #:text '()))
662                 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
663                 (base ((expr->base empty) b))
664                 (type (list "struct" "scm")) ;; FIXME
665                 (fields (type->description info type))
666                 (size (type->size info type))
667                 (field-size 4) ;; FIXME:4, not fixed
668                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
669            (append-text info (append (.text expr)
670                                      (.text base)
671                                      (wrap-as (i386:base->accu-address)))))) ; FIXME: size
672
673
674         ;; i = 0;
675         ;; c = f ();
676         ;; i = i + 48;
677         ;; p = g_cell;
678         ((assn-expr (p-expr (ident ,name)) (op ,op) ,b)
679          (when (and (not (equal? op "="))
680                     (not (equal? op "+="))
681                     (not (equal? op "-=")))
682            (stderr "OOOPS1: op=~s\n" op)
683            barf)
684          (let* ((empty (clone info #:text '()))
685                 (base ((expr->base empty) b)))
686            (append-text info (append (.text base)
687                                      (if (equal? op "=") '()
688                                          (append ((ident->accu info) name)
689                                                  (wrap-as (append (if (equal? op "+=") (i386:accu+base)
690                                                                       (i386:accu-base))
691                                                                   (i386:accu->base)))))
692                                      ;;assign:
693                                      ((base->ident info) name)
694                                      (wrap-as (i386:base->accu))))))
695         
696         ;; *p = 0;
697         ((assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b)
698          (when (not (equal? op "="))
699            (stderr "OOOPS2: op=~s\n" op)
700            barf)
701          (let* ((empty (clone info #:text '()))
702                 (base ((expr->base empty) b)))
703            (append-text info (append (.text base)
704                                      ;;assign:
705                                      ((base->ident-address info) array)
706                                      (wrap-as (i386:base->accu))))))
707
708         ;; g_cells[<expr>] = <expr>;
709         ((assn-expr (array-ref ,index (p-expr (ident ,array))) (op ,op) ,b)
710          (when (not (equal? op "="))
711            (stderr "OOOPS3: op=~s\n" op)
712            barf)
713          (let* ((info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
714                 (info ((expr->+base info) b))
715                 (type (ident->type info array))
716                 (size (type->size info type))
717                 (ptr (ident->pointer info array)))
718            (append-text info (append
719                               (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
720                                   (append
721                                    (wrap-as (i386:base-address->accu-address))
722                                    (if (<= size 4) '()
723                                        (wrap-as (append (i386:accu+n 4)
724                                                         (i386:base+n 4)
725                                                         (i386:base-address->accu-address))))
726                                    (if (<= size 8) '()
727                                        (wrap-as (append (i386:accu+n 4)
728                                                         (i386:base+n 4)
729                                                         (i386:base-address->accu-address))))))))))
730
731         (_
732          (format (current-error-port) "SKIP: expr->accu=~s\n" o)
733          barf
734          info)))))
735
736 (define (expr->+base info)
737   (lambda (o)
738     (let* ((info (append-text info (wrap-as (i386:push-accu))))
739            (info ((expr->accu info) o))
740            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
741       info)))
742
743 (define (binop->accu info)
744   (lambda (a b c)
745     (let* ((info ((expr->accu info) a))
746            (info ((expr->+base info) b)))
747       (append-text info (wrap-as c)))))
748
749 (define (append-text info text)
750   (clone info #:text (append (.text info) text)))
751
752 (define (wrap-as o)
753   (list (lambda (f g ta t d) o)))
754
755 (define (expr->base info) ;; JUNKME
756   (lambda (o)
757     (let ((info ((expr->accu info) o)))
758       (clone info
759              #:text (append (wrap-as (i386:push-accu))
760                             (.text info)
761                             (wrap-as (append (i386:accu->base)
762                                              (i386:pop-accu))))))))
763
764 (define (expr->accu* info)
765   (lambda (o)
766     ;; (stderr "expr->accu* o=~s\n" o)
767
768     (pmatch o
769       ;; g_cells[<expr>]
770       ((array-ref ,index (p-expr (ident ,array)))
771        (let* ((info ((expr->accu info) index))
772               (type (ident->type info array))
773               (size (type->size info type)))
774          (append-text info (append (wrap-as (append (i386:accu->base)
775                                                     (if (eq? size 1) '()
776                                                         (append
777                                                          (if (<= size 4) '()
778                                                              (i386:accu+accu))
779                                                          (if (<= size 8) '()
780                                                              (i386:accu+base))
781                                                          (i386:accu-shl 2)))))
782                                    ((ident->base info) array)
783                                    (wrap-as (i386:accu+base))))))
784
785       ;; g_cells[10].type
786       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
787        (let* ((type (ident->type info array))
788               (fields (or (type->description info type) '()))
789               (size (type->size info type))
790               (count (length fields))
791               (field-size 4) ;; FIXME:4, not fixed
792               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
793               (index (cstring->number index))
794               (text (.text info)))
795          (append-text info (append (wrap-as (append (i386:value->base index)
796                                                     (i386:base->accu)
797                                                     (if (<= count 1) '()
798                                                         (i386:accu+accu))
799                                                     (if (<= count 2) '()
800                                                         (i386:accu+base))
801                                                     (i386:accu-shl 2)))
802                                    ;; de-ref: g_cells, non: arena
803                                    ;;((ident->base info) array)
804                                    ((ident->base info) array)
805                                    (wrap-as (append (i386:accu+base)
806                                                     (i386:accu+value offset)))))))
807
808       ;; g_cells[x].type
809       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
810        (let* ((type (ident->type info array))
811               (fields (or (type->description info type) '()))
812               (size (type->size info type))
813               (count (length fields))
814               (field-size 4) ;; FIXME:4, not fixed
815               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
816               (text (.text info)))
817          (append-text info (append ((ident->base info) index)
818                                    (wrap-as (append (i386:base->accu)
819                                                     (if (<= count 1) '()
820                                                         (i386:accu+accu))
821                                                     (if (<= count 2) '()
822                                                         (i386:accu+base))
823                                                     (i386:accu-shl 2)))
824                                    ;; de-ref: g_cells, non: arena
825                                    ;;((ident->base info) array)
826                                    ((ident->base info) array)
827                                    (wrap-as (append (i386:accu+base)
828                                                     (i386:accu+value offset)))))))
829
830       ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
831       ((d-sel (ident ,field) (p-expr (ident ,name)))
832        (let* ((type (ident->type info name))
833               (fields (or (type->description info type) '()))
834               (field-size 4) ;; FIXME
835               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
836               (text (.text info)))
837          (append-text info (append ((ident->accu info) name)
838                                    (wrap-as (i386:accu+value offset))))))
839
840       (_
841        (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
842        barf
843        info)
844       )))
845
846 (define (ident->constant name value)
847   (cons name value))
848
849 (define (make-type name type size description)
850   (cons name (list type size description)))
851
852 (define (enum->type name fields)
853   (make-type name 'enum 4 fields))
854
855 (define (struct->type name fields)
856   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
857
858 (define (decl->type o)
859   (pmatch o
860     ((fixed-type ,type) type)
861     ((struct-ref (ident ,name)) (list "struct" name))
862     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
863      (list "struct" name)) ;; FIXME
864     ((typename ,name) name)
865     (_
866      (stderr "SKIP: decl type=~s\n" o)
867      barf
868      o)))
869
870 (define (expr->global o)
871   (pmatch o
872     ((p-expr (string ,string)) (string->global string))
873     (_ #f)))
874
875 (define (initzer->global o)
876   (pmatch o
877     ((initzer ,initzer) (expr->global initzer))
878     (_ #f)))
879
880 (define (byte->hex o)
881   (string->number (string-drop o 2) 16))
882
883 (define (asm->hex o)
884   (let ((prefix ".byte "))
885     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
886         (let ((s (string-drop o (string-length prefix))))
887           (map byte->hex (string-split s #\space))))))
888
889 (define (case->jump-info info)
890   (define (jump n)
891     (wrap-as (i386:Xjump n)))
892   (define (jump-nz n)
893     (wrap-as (i386:Xjump-nz n)))
894   (define (statement->info info body-length)
895     (lambda (o)
896       (pmatch o
897         ((break) (append-text info (jump body-length)))
898         (_
899          ((ast->info info) o)))))
900   (lambda (o)
901     (pmatch o
902       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
903        (lambda (body-length)
904
905          (define (test->text value clause-length)
906            (append (wrap-as (i386:accu-cmp-value value))
907                    (jump-nz clause-length)))
908          (let* ((value (assoc-ref (.constants info) constant))
909                 (test-info (append-text info (test->text value 0)))
910                 (text-length (length (.text test-info)))
911                 (clause-info (let loop ((elements elements) (info test-info))
912                                (if (null? elements) info
913                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
914                 (clause-text (list-tail (.text clause-info) text-length))
915                 (clause-length (length (text->list clause-text))))
916            (clone info #:text (append
917                                (.text info)
918                                (test->text value clause-length)
919                                clause-text)
920                   #:globals (.globals clause-info)))))
921
922       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
923        (lambda (body-length)
924
925          (define (test->text value clause-length)
926            (append (wrap-as (i386:accu-cmp-value value))
927                    (jump-nz clause-length)))
928          (let* ((value (cstring->number value))
929                 (test-info (append-text info (test->text value 0)))
930                 (text-length (length (.text test-info)))
931                 (clause-info (let loop ((elements elements) (info test-info))
932                                (if (null? elements) info
933                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
934                 (clause-text (list-tail (.text clause-info) text-length))
935                 (clause-length (length (text->list clause-text))))
936            (clone info #:text (append
937                                (.text info)
938                                (test->text value clause-length)
939                                clause-text)
940                   #:globals (.globals clause-info)))))
941
942       ((case (neg (p-expr (fixed ,value))) ,statement)
943        ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
944
945       ((default (compd-stmt (block-item-list . ,elements)))
946        (lambda (body-length)
947          (let ((text-length (length (.text info))))
948            (let loop ((elements elements) (info info))
949              (if (null? elements) info
950                  (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
951
952       ((case (p-expr (ident ,constant)) ,statement)
953        ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
954
955       ((case (p-expr (fixed ,value)) ,statement)
956        ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
957
958       ((default ,statement)
959        ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
960
961       (_ (stderr "no case match: ~a\n" o) barf)
962       )))
963
964 (define (test->jump->info info)
965   (define (jump type . test)
966     (lambda (o)
967       (let* ((text (.text info))
968              (info (clone info #:text '()))
969              (info ((ast->info info) o))
970              (jump-text (lambda (body-length)
971                           (wrap-as (type body-length)))))
972         (lambda (body-length)
973           (clone info #:text
974                  (append text
975                          (.text info)
976                          (if (null? test) '() (car test))
977                          (jump-text body-length)))))))
978   (lambda (o)
979     (pmatch o
980       ;; unsigned
981       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
982       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
983       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
984       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
985
986       ((le ,a ,b) ((jump i386:Xjump-g) o))
987       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
988       ((ge ,a ,b) ((jump i386:Xjump-g) o))
989       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
990
991       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
992       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
993       ((not _) ((jump i386:Xjump-z) o))
994       ((and ,a ,b)
995        (let* ((text (.text info))
996               (info (clone info #:text '()))
997
998               (a-jump ((test->jump->info info) a))
999               (a-text (.text (a-jump 0)))
1000               (a-length (length (text->list a-text)))
1001
1002               (b-jump ((test->jump->info info) b))
1003               (b-text (.text (b-jump 0)))
1004               (b-length (length (text->list b-text))))
1005
1006          (lambda (body-length)
1007            (clone info #:text
1008                   (append text
1009                           (.text (a-jump (+ b-length body-length)))
1010                           (.text (b-jump body-length)))))))
1011       ((or ,a ,b)
1012        (let* ((text (.text info))
1013               (info (clone info #:text '()))
1014
1015               (a-jump ((test->jump->info info) a))
1016               (a-text (.text (a-jump 0)))
1017               (a-length (length (text->list a-text)))
1018
1019               (jump-text (wrap-as (i386:Xjump 0)))
1020               (jump-length (length (text->list jump-text)))
1021
1022               (b-jump ((test->jump->info info) b))
1023               (b-text (.text (b-jump 0)))
1024               (b-length (length (text->list b-text)))
1025
1026               (jump-text (wrap-as (i386:Xjump b-length))))
1027
1028          (lambda (body-length)
1029            (clone info #:text
1030                   (append text
1031                           (.text (a-jump jump-length))
1032                           jump-text
1033                           (.text (b-jump body-length)))))))
1034
1035       ((array-ref . _) ((jump i386:jump-byte-z
1036                               (wrap-as (i386:accu-zero?))) o))
1037
1038       ((de-ref _) ((jump i386:jump-byte-z
1039                          (wrap-as (i386:accu-zero?))) o))
1040
1041       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1042        ((jump i386:Xjump-z
1043               (append
1044                ((ident->accu info) name)
1045                (wrap-as (i386:accu-zero?)))) o))
1046
1047       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1048
1049 (define (cstring->number s)
1050   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1051         ((string-prefix? "0" s) (string->number s 8))
1052         (else (string->number s))))
1053
1054 (define (struct-field o)
1055   (pmatch o
1056     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1057                 (comp-declr-list (comp-declr (ident ,name))))
1058      (cons type name))
1059     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1060      (cons type name))
1061     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1062      (cons type name))
1063     ((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)))))))))
1064      (cons type name)) ;; FIXME function / int
1065     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1066      (cons type name)) ;; FIXME: ptr/char
1067     (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1068
1069 (define (ast->type o)
1070   (pmatch o
1071     ((fixed-type ,type)
1072      type)
1073     ((struct-ref (ident ,type))
1074      (list "struct" type))
1075     (_ (stderr "SKIP: type=~s\n" o)
1076        "int")))
1077
1078 (define i386:type-alist
1079   '(("char" . (builtin 1 #f))
1080     ("int" . (builtin 4 #f))))
1081
1082 (define (type->size info o)
1083   ;;(stderr  "types=~s\n" (.types info))
1084   ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
1085   (pmatch o
1086     ((decl-spec-list (type-spec (fixed-type ,type)))
1087      (type->size info type))
1088     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1089      (type->size info type))
1090     (_ (let ((type (assoc-ref (.types info) o)))
1091          (if type (cadr type)
1092              (begin
1093                (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1094                barf
1095                4))))))
1096
1097 (define (ident->decl info o)
1098   ;; (stderr "ident->decl o=~s\n" o)
1099   ;; (stderr "  types=~s\n" (.types info))
1100   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
1101   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
1102   (or (assoc-ref (.locals info) o)
1103       (assoc-ref (.globals info) o)
1104       (begin
1105         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1106         (assoc-ref (.functions info) o))))
1107
1108 (define (ident->type info o)
1109   (and=> (ident->decl info o) car))
1110
1111 (define (ident->pointer info o)
1112   (let ((local (assoc-ref (.locals info) o)))
1113     (if local (local:pointer local)
1114         (or (and=> (ident->decl info o) global:pointer) 0))))
1115
1116 (define (type->description info o)
1117   ;; (stderr  "type->description =~s\n" o)  
1118   ;; (stderr  "types=~s\n" (.types info))
1119   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
1120   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
1121   (pmatch o
1122     ((decl-spec-list (type-spec (fixed-type ,type)))
1123      (type->description info type))
1124     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1125      (type->description info type))
1126     (_ (caddr (assoc-ref (.types info) o)))))
1127
1128 (define (local? o) ;; formals < 0, locals > 0
1129   (positive? (local:id o)))
1130
1131 (define (ast->info info)
1132   (lambda (o)
1133     (let ((globals (.globals info))
1134           (locals (.locals info))
1135           (constants (.constants info))
1136           (text (.text info)))
1137       (define (add-local locals name type pointer)
1138         (let* ((id (1+ (length (filter local? (map cdr locals)))))
1139                (locals (cons (make-local name type pointer id) locals)))
1140           locals))
1141
1142       ;; (stderr "\n ast->info=~s\n" o)
1143       ;; (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)))
1144       ;; (stderr "  text=~a\n" text)
1145       ;; (stderr "   info=~a\n" info)
1146       ;; (stderr "   globals=~a\n" globals)
1147       (pmatch o
1148         (((trans-unit . _) . _)
1149          ((ast-list->info info)  o))
1150         ((trans-unit . ,elements)
1151          ((ast-list->info info) elements))
1152         ((fctn-defn . _) ((function->info info) o))
1153         ((comment . _) info)
1154         ((cpp-stmt (define (name ,name) (repl ,value)))
1155          info)
1156
1157         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1158          info)
1159
1160         ;; FIXME: expr-stmt wrapper?
1161         (trans-unit info)
1162         ((expr-stmt) info)
1163
1164         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1165         
1166         ((if ,test ,body)
1167          (let* ((text-length (length text))
1168
1169                 (test-jump->info ((test->jump->info info) test))
1170                 (test+jump-info (test-jump->info 0))
1171                 (test-length (length (.text test+jump-info)))
1172
1173                 (body-info ((ast->info test+jump-info) body))
1174                 (text-body-info (.text body-info))
1175                 (body-text (list-tail text-body-info test-length))
1176                 (body-length (length (text->list body-text)))
1177
1178                 (text+test-text (.text (test-jump->info body-length)))
1179                 (test-text (list-tail text+test-text text-length)))
1180
1181            (clone info #:text
1182                   (append text
1183                           test-text
1184                           body-text)
1185                   #:globals (.globals body-info))))
1186
1187         ((if ,test ,then ,else)
1188          (let* ((text-length (length text))
1189
1190                 (test-jump->info ((test->jump->info info) test))
1191                 (test+jump-info (test-jump->info 0))
1192                 (test-length (length (.text test+jump-info)))
1193
1194                 (then-info ((ast->info test+jump-info) then))
1195                 (text-then-info (.text then-info))
1196                 (then-text (list-tail text-then-info test-length))
1197                 (then-jump-text (wrap-as (i386:Xjump 0)))
1198                 (then-jump-length (length (text->list then-jump-text)))
1199                 (then-length (+ (length (text->list then-text)) then-jump-length))
1200
1201                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1202                 (else-info ((ast->info then+jump-info) else))
1203                 (text-else-info (.text else-info))
1204                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1205                 (else-length (length (text->list else-text)))
1206
1207                 (text+test-text (.text (test-jump->info then-length)))
1208                 (test-text (list-tail text+test-text text-length))
1209                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1210
1211            (clone info #:text
1212                   (append text
1213                           test-text
1214                           then-text
1215                           then-jump-text
1216                           else-text)
1217                   #:globals (append (.globals then-info)
1218                                     (list-tail (.globals else-info) (length globals))))))
1219
1220         ;; Hmm?
1221         ((expr-stmt (cond-expr ,test ,then ,else))
1222          (let* ((text-length (length text))
1223
1224                 (test-jump->info ((test->jump->info info) test))
1225                 (test+jump-info (test-jump->info 0))
1226                 (test-length (length (.text test+jump-info)))
1227
1228                 (then-info ((ast->info test+jump-info) then))
1229                 (text-then-info (.text then-info))
1230                 (then-text (list-tail text-then-info test-length))
1231                 (then-length (length (text->list then-text)))
1232
1233                 (jump-text (wrap-as (i386:Xjump 0)))
1234                 (jump-length (length (text->list jump-text)))
1235
1236                 (test+then+jump-info
1237                  (clone then-info
1238                         #:text (append (.text then-info) jump-text)))
1239
1240                 (else-info ((ast->info test+then+jump-info) else))
1241                 (text-else-info (.text else-info))
1242                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1243                 (else-length (length (text->list else-text)))
1244
1245                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1246                 (test-text (list-tail text+test-text text-length))
1247                 (jump-text (wrap-as (i386:Xjump else-length))))
1248
1249            (clone info #:text
1250                   (append text
1251                           test-text
1252                           then-text
1253                           jump-text
1254                           else-text)
1255                   #:globals (.globals else-info))))
1256
1257         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1258          (let* ((expr ((expr->accu info) expr))
1259                 (empty (clone info #:text '()))
1260                 (case-infos (map (case->jump-info empty) cases))
1261                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1262                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1263                               (if (null? cases) info
1264                                   (let ((c-j ((case->jump-info info) (car cases))))
1265                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1266            cases-info))
1267
1268         ((for ,init ,test ,step ,body)
1269          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1270
1271                 (info ((ast->info info) init))
1272
1273                 (init-text (.text info))
1274                 (init-locals (.locals info))
1275                 (info (clone info #:text '()))
1276
1277                 (body-info ((ast->info info) body))
1278                 (body-text (.text body-info))
1279                 (body-length (length (text->list body-text)))
1280
1281                 (step-info ((expr->accu info) step))
1282                 (step-text (.text step-info))
1283                 (step-length (length (text->list step-text)))
1284
1285                 (test-jump->info ((test->jump->info info) test))
1286                 (test+jump-info (test-jump->info 0))
1287                 (test-length (length (text->list (.text test+jump-info))))
1288
1289                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1290
1291                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1292                 (jump-length (length (text->list jump-text)))
1293
1294                 (test-text (.text (test-jump->info jump-length))))
1295
1296            (clone info #:text
1297                   (append text
1298                           init-text
1299                           skip-body-text
1300                           body-text
1301                           step-text
1302                           test-text
1303                           jump-text)
1304                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1305                   #:locals locals)))
1306
1307         ;; FIXME: support break statement (see switch/case)
1308         ((while ,test ,body)
1309          (let* ((skip-info (lambda (body-length)
1310                              (clone info #:text (append text
1311                                                         (wrap-as (i386:Xjump body-length))))))
1312                 (text (.text (skip-info 0)))
1313                 (text-length (length text))
1314
1315                 (body-info (lambda (body-length)
1316                              ((ast->info (skip-info body-length)) body)))
1317                 (body-text (list-tail (.text (body-info 0)) text-length))
1318                 (body-length (length (text->list body-text)))
1319
1320                 (body-info (body-info body-length))
1321
1322                 (empty (clone info #:text '()))
1323                 (test-jump->info ((test->jump->info empty) test))
1324                 (test+jump-info (test-jump->info 0))
1325                 (test-length (length (text->list (.text test+jump-info))))
1326
1327                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1328                 (jump-length (length (text->list jump-text)))
1329
1330                 (test-text (.text (test-jump->info jump-length))))
1331            (clone info #:text
1332                   (append
1333                    (.text body-info)
1334                    test-text
1335                    jump-text)
1336                   #:globals (.globals body-info))))
1337
1338         ((do-while ,body ,test)
1339          (let* ((text-length (length text))
1340
1341                 (body-info ((ast->info info) body))
1342                 (body-text (list-tail (.text body-info) text-length))
1343                 (body-length (length (text->list body-text)))
1344
1345                 (empty (clone info #:text '()))
1346                 (test-jump->info ((test->jump->info empty) test))
1347                 (test+jump-info (test-jump->info 0))
1348                 (test-length (length (text->list (.text test+jump-info))))
1349
1350                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1351                 (jump-length (length (text->list jump-text)))
1352
1353                 (test-text (.text (test-jump->info jump-length))))
1354            (clone info #:text
1355                   (append
1356                    (.text body-info)
1357                    test-text
1358                    jump-text)
1359                   #:globals (.globals body-info))))
1360
1361         ((labeled-stmt (ident ,label) ,statement)
1362          (let ((info (append-text info (list label))))
1363            ((ast->info info) statement)))
1364
1365         ((goto (ident ,label))
1366          (let* ((jump (lambda (n) (i386:XXjump n)))
1367                 (offset (+ (length (jump 0)) (length (text->list text)))))
1368            (append-text info (append 
1369                               (list (lambda (f g ta t d)
1370                                       (jump (- (label-offset (.function info) label f) offset))))))))
1371
1372         ((return ,expr)
1373          (let ((info ((expr->accu info) expr)))
1374            (append-text info (append  (wrap-as (i386:ret)))))) 
1375
1376         ;; DECL
1377
1378         ;; int i;
1379         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1380          (if (.function info)
1381              (clone info #:locals (add-local locals name type 0))
1382              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1383
1384         ;; int i = 0;
1385         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1386          (let ((value (cstring->number value)))
1387            (if (.function info)
1388                (let* ((locals (add-local locals name type 0))
1389                       (info (clone info #:locals locals)))
1390                  (append-text info ((value->ident info) name value)))
1391                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1392
1393         ;; char c = 'A';
1394         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1395          (if (not (.function info)) decl-barf0)
1396          (let* ((locals (add-local locals name type 0))
1397                 (info (clone info #:locals locals))
1398                 (value (char->integer (car (string->list value)))))
1399            (append-text info ((value->ident info) name value))))
1400
1401         ;; int i = -1;
1402         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1403          (let ((value (- (cstring->number value))))
1404            (if (.function info)
1405                (let* ((locals (add-local locals name type 0))
1406                       (info (clone info #:locals locals)))
1407                  (append-text info ((value->ident info) name value)))
1408                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1409
1410         ;; int i = argc;
1411         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1412          (if (not (.function info)) decl-barf2)
1413          (let* ((locals (add-local locals name type 0))
1414                 (info (clone info #:locals locals)))
1415            (append-text info (append ((ident->accu info) local)
1416                                      ((accu->ident info) name)))))
1417
1418         ;; char *p = "t.c";
1419         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1420          (when (not (.function info))
1421            (stderr "o=~s\n" o)
1422            decl-barf3)
1423          (let* ((locals (add-local locals name type 1))
1424                 (globals (append globals (list (string->global string))))
1425                 (info (clone info #:locals locals #:globals globals)))
1426            (append-text info (append
1427                               (list (lambda (f g ta t d)
1428                                       (append
1429                                        (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1430                               ((accu->ident info) name)))))
1431         
1432         ;; char *p = 0;
1433         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1434          (let ((value (cstring->number value)))
1435            (if (.function info)
1436                (let* ((locals (add-local locals name type 1))
1437                       (info (clone info #:locals locals)))
1438                  (append-text info (append (wrap-as (i386:value->accu value))
1439                                            ((accu->ident info) name))))
1440                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1441
1442         ;; char arena[20000];
1443         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1444          (let ((type (ast->type type)))
1445            (if (.function info)
1446                TODO:decl-array 
1447                (let* ((globals (.globals info))
1448                       (count (cstring->number count))
1449                       (size (type->size info type))
1450                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1451                       (globals (append globals (list array))))
1452                  (clone info #:globals globals)))))
1453
1454         ;;struct scm *g_cells = (struct scm*)arena;
1455         ((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)))))))
1456          ;;(stderr "0TYPE: ~s\n" type)
1457          (if (.function info)
1458              (let* ((locals (add-local locals name type 1))
1459                     (info (clone info #:locals locals)))
1460                (append-text info (append ((ident->accu info) name)
1461                                          ((accu->ident info) value)))) ;; FIXME: deref?
1462              (let* ((globals (append globals (list (ident->global name type 1 0))))
1463                     (info (clone info #:globals globals)))
1464                (append-text info (append ((ident->accu info) name)
1465                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1466
1467         ;; SCM tmp;
1468         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1469          ;;(stderr  "1TYPE: ~s\n" type)
1470          (if (.function info)
1471              (clone info #:locals (add-local locals name type 0))
1472              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1473
1474         ;; SCM g_stack = 0;
1475         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1476          ;;(stderr  "2TYPE: ~s\n" type)
1477          (let ((value (cstring->number value)))
1478            (if (.function info)
1479                (let* ((locals (add-local locals name type 0))
1480                       (info (clone info #:locals locals)))
1481                  (append-text info ((value->ident info) name value)))
1482                (let ((globals (append globals (list (ident->global name type 0 value)))))
1483                  (clone info #:globals globals)))))
1484
1485         ;; SCM g_stack = 0; // comment
1486         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1487          ((ast->info info) (list-head o (- (length o) 1))))
1488
1489         ;; SCM i = argc;
1490         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1491          ;;(stderr  "3TYPE: ~s\n" type)
1492          (if (.function info)
1493              (let* ((locals (add-local locals name type 0))
1494                     (info (clone info #:locals locals)))
1495                (append-text info (append ((ident->accu info) local)
1496                                          ((accu->ident info) name))))
1497              (let* ((globals (append globals (list (ident->global name type 0 0))))
1498                     (info (clone info #:globals globals)))
1499                (append-text info (append ((ident->accu info) local)
1500                                          ((accu->ident info) name))))))
1501
1502         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1503         ((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))))
1504          (let* ((locals (add-local locals name type 1))
1505                 (info (clone info #:locals locals))
1506                 (empty (clone info #:text '()))
1507                 (accu ((expr->accu empty) initzer)))
1508            (clone info
1509                   #:text
1510                   (append text
1511                           (.text accu)
1512                           ((accu->ident info) name)
1513                           (list (lambda (f g ta t d)
1514                                   (append (i386:value->base ta)
1515                                           (i386:accu+base)))))
1516                   #:locals locals)))
1517
1518         ;; char *p = (char*)g_cells;
1519         ((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)))))))
1520          ;;(stderr  "6TYPE: ~s\n" type)
1521          (if (.function info)
1522              (let* ((locals (add-local locals name type 1))
1523                     (info (clone info #:locals locals)))
1524                (append-text info (append ((ident->accu info) value)
1525                                          ((accu->ident info) name))))
1526              (let* ((globals (append globals (list (ident->global name type 1 0))))
1527                     (here (data-offset name globals))
1528                     (there (data-offset value globals)))
1529                (clone info
1530                       #:globals globals
1531                       #:init (append (.init info)
1532                                      (list (lambda (functions globals ta t d data)
1533                                              (append
1534                                               (list-head data here)
1535                                               ;;; FIXME: type
1536                                               ;;; char *x = arena;
1537                                               (int->bv32 (+ d (data-offset value globals)))
1538                                               ;;; char *y = x;
1539                                               ;;;(list-head (list-tail data there) 4)
1540                                               (list-tail data (+ here 4))))))))))
1541
1542         ;; char *p = g_cells;
1543         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1544          ;;(stderr  "7TYPE: ~s\n" type)
1545          (let ((type (decl->type type)))
1546            ;;(stderr "0DECL: ~s\n" type)
1547            (if (.function info)
1548                (let* ((locals (add-local locals name type  1))
1549                       (info (clone info #:locals locals)))
1550                  (append-text info (append ((ident->accu info) value)
1551                                            ((accu->ident info) name))))
1552                (let* ((globals (append globals (list (ident->global name type 1 0))))
1553                       (here (data-offset name globals)))
1554                  (clone info
1555                         #:globals globals
1556                         #:init (append (.init info)
1557                                        (list (lambda (functions globals ta t d data)
1558                                                (append
1559                                                 (list-head data here)
1560                                               ;;; FIXME: type
1561                                               ;;; char *x = arena;p
1562                                                 (int->bv32 (+ d (data-offset value globals)))
1563                                                 (list-tail data (+ here 4)))))))))))
1564
1565         ;; enum 
1566         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1567          (let ((type (enum->type name fields))
1568                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1569            (clone info
1570                   #:types (append (.types info) (list type))
1571                   #:constants (append constants (.constants info)))))
1572
1573         ;; struct
1574         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1575          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1576            ;;(stderr "type: ~a\n" type)
1577            (clone info #:types (append (.types info) (list type)))))
1578
1579         ;; DECL
1580         ;;
1581         ;; struct f = {...};
1582         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1583          (let* ((type (decl->type type))
1584                 ;;(foo (stderr "1DECL: ~s\n" type))
1585                 (fields (type->description info type))
1586                 (size (type->size info type))
1587                 (field-size 4))  ;; FIXME:4, not fixed
1588            ;;(stderr  "7TYPE: ~s\n" type)
1589            (if (.function info)
1590                (let* ((globals (append globals (filter-map initzer->global initzers)))
1591                       (locals (let loop ((fields (cdr fields)) (locals locals))
1592                                 (if (null? fields) locals
1593                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1594                       (locals (add-local locals name type -1))
1595                       (info (clone info #:locals locals #:globals globals))
1596                       (empty (clone info #:text '())))
1597                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1598                    (if (null? fields) info
1599                        (let ((offset (* field-size (car fields)))
1600                              (initzer (car initzers)))
1601                          (loop (cdr fields) (cdr initzers)
1602                                (clone info #:text
1603                                       (append
1604                                        (.text info)
1605                                        ((ident->accu info) name)
1606                                        (wrap-as (append (i386:accu->base)))
1607                                        (.text ((expr->accu empty) initzer))
1608                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1609                (let* ((globals (append globals (filter-map initzer->global initzers)))
1610                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1611                       (globals (append globals (list global)))
1612                       (here (data-offset name globals))
1613                       (info (clone info #:globals globals))
1614                       (field-size 4))
1615                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1616                    (if (null? fields) info
1617                        (let ((offset (* field-size (car fields)))
1618                              (initzer (car initzers)))
1619                          (loop (cdr fields) (cdr initzers)
1620                                (clone info #:init
1621                                       (append
1622                                        (.init info)
1623                                        (list (lambda (functions globals ta t d data)
1624                                                (append
1625                                                 (list-head data (+ here offset))
1626                                                 (initzer->data info functions globals ta t d (car initzers))
1627                                                 (list-tail data (+ here offset field-size)))))))))))))))
1628
1629
1630         ;;char cc = g_cells[c].cdr;  ==> generic?
1631         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1632          (let ((type (decl->type type)))
1633            (if (.function info)
1634                (let* ((locals (add-local locals name type 0))
1635                       (info (clone info #:locals locals)))
1636                  (clone info #:text
1637                         (append (.text ((expr->accu info) initzer))
1638                                 ((accu->ident info) name))))
1639                (let* ((globals (append globals (list (ident->global name type 1 0))))
1640                       (here (data-offset name globals)))
1641                  (clone info
1642                         #:globals globals
1643                         #:init (append (.init info)
1644                                        (list (lambda (functions globals ta t d data)
1645                                                (append
1646                                                 (list-head data here)
1647                                                 (initzer->data info functions globals ta t d initzer)
1648                                                 (list-tail data (+ here 4)))))))))))
1649
1650
1651         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1652          info)
1653
1654         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1655          info)
1656
1657         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1658          (let ((types (.types info)))
1659            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1660
1661         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1662          (format (current-error-port) "SKIP: typedef=~s\n" o)
1663          info)
1664
1665         ((decl (@ ,at))
1666          (format (current-error-port) "SKIP: at=~s\n" o)
1667          info)
1668
1669         ((decl . _)
1670          (format (current-error-port) "SKIP: decl statement=~s\n" o)
1671          barf
1672          info)
1673
1674         ;; ...
1675         ((gt . _) ((expr->accu info) o))
1676         ((ge . _) ((expr->accu info) o))
1677         ((ne . _) ((expr->accu info) o))
1678         ((eq . _) ((expr->accu info) o))
1679         ((le . _) ((expr->accu info) o))
1680         ((lt . _) ((expr->accu info) o))
1681         ((lshift . _) ((expr->accu info) o))
1682         ((rshift . _) ((expr->accu info) o))
1683
1684         ;; EXPR
1685         ((expr-stmt ,expression)
1686          (let ((info ((expr->accu info) expression)))
1687            (append-text info (wrap-as (i386:accu-zero?)))))
1688
1689         ;; FIXME: why do we get (post-inc ...) here
1690         ;; (array-ref
1691         (_ (let ((info ((expr->accu info) o)))
1692              (append-text info (wrap-as (i386:accu-zero?)))))))))
1693
1694 (define (initzer->data info functions globals ta t d o)
1695   (pmatch o
1696     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1697     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1698     ((initzer (ref-to (p-expr (ident ,name))))
1699      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
1700      (int->bv32 (+ ta (function-offset name functions))))
1701     ((initzer (p-expr (ident ,name)))
1702      (let ((value (assoc-ref (.constants info) name)))
1703        (int->bv32 value)))
1704     ((initzer (p-expr (string ,string)))
1705      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
1706     (_ (stderr "initzer->data:SKIP: ~s\n" o)
1707        barf
1708        (int->bv32 0))))
1709
1710 (define (info->exe info)
1711   (display "dumping elf\n" (current-error-port))
1712   (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
1713
1714 (define (.formals o)
1715   (pmatch o
1716     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1717     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1718     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
1719        barf)))
1720
1721 (define (formal->text n)
1722   (lambda (o i)
1723     ;;(i386:formal i n)
1724     '()
1725     ))
1726
1727 (define (formals->text o)
1728   (pmatch o
1729     ((param-list . ,formals)
1730      (let ((n (length formals)))
1731        (wrap-as (append (i386:function-preamble)
1732                         (append-map (formal->text n) formals (iota n))
1733                         (i386:function-locals)))))
1734     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
1735        barf)))
1736
1737 (define (formal:ptr o)
1738   (pmatch o
1739     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1740      1)
1741     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
1742      0)
1743     (_
1744      (stderr "formal:ptr[~a] => 0\n" o)
1745      0)))
1746
1747 (define (formals->locals o)
1748   (pmatch o
1749     ((param-list . ,formals)
1750      (let ((n (length formals)))
1751        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
1752     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
1753        barf)))
1754
1755 (define (function->info info)
1756   (lambda (o)
1757     ;;(stderr "function->info o=~s\n" o)
1758     ;;(stderr "formals=~s\n" (.formals o))
1759     (let* ((name (.name o))
1760            (formals (.formals o))
1761            (text (formals->text formals))
1762            (locals (formals->locals formals)))
1763       (format (current-error-port) "compiling ~s\n" name)
1764       ;;(stderr "locals=~s\n" locals)
1765       (let loop ((statements (.statements o))
1766                  (info (clone info #:locals locals #:function (.name o) #:text text)))
1767         (if (null? statements) (clone info
1768                                       #:function #f
1769                                       #:functions (append (.functions info) (list (cons name (.text info)))))
1770             (let* ((statement (car statements)))
1771               (loop (cdr statements)
1772                     ((ast->info info) (car statements)))))))))
1773
1774 (define (ast-list->info info)
1775   (lambda (elements)
1776     (let loop ((elements elements) (info info))
1777       (if (null? elements) info
1778           (loop (cdr elements) ((ast->info info) (car elements)))))))
1779
1780 (define (compile)
1781   (stderr "COMPILE\n")
1782   (let* ((ast (mescc))
1783          (info (make <info>
1784                  #:functions i386:libc
1785                  #:types i386:type-alist))
1786          (ast (append libc ast))
1787          (info ((ast->info info) ast))
1788          (info ((ast->info info) _start)))
1789     (info->exe info)))