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