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