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