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