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