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