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