mescc: Run mini-mes.
[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->Xaccu 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->Xaccu=~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          (let* ((value (assoc-ref (.constants info) constant))
801                 (text-length (length (.text info)))
802                 (clause-info (let loop ((elements elements) (info info))
803                                (if (null? elements) info
804                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
805                 (clause-text (list-tail (.text clause-info) text-length))
806                 (clause-length (length (text->list clause-text))))
807            (clone info #:text (append
808                                (.text info)
809                                (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
810                                (jump-nz clause-length)
811                                clause-text)
812                   #:globals (.globals clause-info)))))
813
814       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
815        (lambda (body-length)
816          (let* ((value (cstring->number value))
817                 (text-length (length (.text info)))
818                 (clause-info (let loop ((elements elements) (info info))
819                                (if (null? elements) info
820                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
821                 (clause-text (list-tail (.text clause-info) text-length))
822                 (clause-length (length (text->list clause-text))))
823            (clone info #:text (append
824                                (.text info)
825                                (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
826                                (jump-nz clause-length)
827                                clause-text)
828                   #:globals (.globals clause-info)))))
829
830       ((default (compd-stmt (block-item-list . ,elements)))
831        (lambda (body-length)
832          (let ((text-length (length (.text info))))
833           (let loop ((elements elements) (info info))
834             (if (null? elements) info
835                 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
836       (_ (stderr "no case match: ~a\n" o) barf)
837       )))
838
839 (define (test->jump->info info)
840   (define (jump type)
841     (lambda (o)
842       (let* ((text (.text info))
843              (info (clone info #:text '()))
844              (info ((ast->info info) o))
845              (jump-text (lambda (body-length)
846                           (list (lambda (f g ta t d) (type body-length))))))
847        (lambda (body-length)
848          (clone info #:text
849                 (append text
850                         (.text info)
851                         (jump-text body-length)))))))
852   (lambda (o)
853     (pmatch o
854       ((lt ,a ,b) ((jump i386:jump-nc) o))
855       ((gt ,a ,b) ((jump i386:jump-nc) o))
856       ((ne ,a ,b) ((jump i386:jump-nz) o))
857       ((eq ,a ,b) ((jump i386:jump-nz) o))
858       ((not _) ((jump i386:jump-z) o))
859       ((and ,a ,b)
860        (let* ((text (.text info))
861               (info (clone info #:text '()))
862
863               (a-jump ((test->jump->info info) a))
864               (a-text (.text (a-jump 0)))
865               (a-length (length (text->list a-text)))
866
867               (b-jump ((test->jump->info info) b))
868               (b-text (.text (b-jump 0)))
869               (b-length (length (text->list b-text))))
870
871          (lambda (body-length)
872            (clone info #:text
873                   (append text
874                           (.text (a-jump (+ b-length body-length)))
875                           (.text (b-jump body-length)))))))
876       ((or ,a ,b)
877        (let* ((text (.text info))
878               (info (clone info #:text '()))
879
880               (a-jump ((test->jump->info info) a))
881               (a-text (.text (a-jump 0)))
882               (a-length (length (text->list a-text)))
883
884               (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
885               (jump-length (length (text->list jump-text)))
886
887               (b-jump ((test->jump->info info) b))
888               (b-text (.text (b-jump 0)))
889               (b-length (length (text->list b-text)))
890
891               (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
892
893          (lambda (body-length)
894            (clone info #:text
895                   (append text
896                           (.text (a-jump jump-length))
897                           jump-text
898                           (.text (b-jump body-length)))))))
899       ((array-ref . _) ((jump i386:jump-byte-z) o))
900       ((de-ref _) ((jump i386:jump-byte-z) o))
901       (_ ((jump i386:jump-z) o)))))
902
903 (define (cstring->number s)
904   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
905         ((string-prefix? "0" s) (string->number s 8))
906         (else (string->number s))))
907
908 (define (struct-field o)
909   (pmatch o
910     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
911                 (comp-declr-list (comp-declr (ident ,name))))
912      (cons type name))
913     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
914      (cons type name))
915     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
916      (cons type name))
917     ((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)))))))))
918      (cons type name)) ;; FIXME function / int
919     (_ (stderr "struct-field: no match: ~a" o) barf)))
920
921 (define (ast->type o)
922   (pmatch o
923     ((fixed-type ,type)
924      type)
925     ((struct-ref (ident ,type))
926      (list "struct" type))
927     (_ (stderr "SKIP: type=~s\n" o)
928        "int")))
929
930 (define i386:type-alist
931   '(("char" . (builtin 1 #f))
932     ("int" . (builtin 4 #f))))
933
934 (define (type->size info o)
935   ;; (stderr  "types=~s\n" (.types info))
936   ;; (stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
937   (cadr (assoc-ref (.types info) o)))
938
939 (define (ident->decl info o)
940   ;; (stderr "ident->decl o=~s\n" o)
941   ;; (stderr "  types=~s\n" (.types info))
942   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
943   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
944   (or (assoc-ref (.locals info) o)
945       (assoc-ref (.globals info) o)
946       (begin
947         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
948         (assoc-ref (.functions info) o))))
949
950 (define (ident->type info o)
951   (and=> (ident->decl info o) car))
952
953 (define (ident->pointer info o)
954   (or (and=> (ident->decl info o) global:pointer) 0))
955
956 (define (type->description info o)
957   ;; (stderr  "type->description =~s\n" o)  
958   ;; (stderr  "types=~s\n" (.types info))
959   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
960   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
961   (caddr (assoc-ref (.types info) o)))
962
963 (define (local? o) ;; formals < 0, locals > 0
964   (positive? (local:id o)))
965
966 (define (ast->info info)
967   (lambda (o)
968     (let ((globals (.globals info))
969           (locals (.locals info))
970           (constants (.constants info))
971           (text (.text info)))
972       (define (add-local locals name type pointer)
973         (let* ((id (1+ (length (filter local? (map cdr locals)))))
974                (locals (cons (make-local name type pointer id) locals)))
975           locals))
976
977       ;; (stderr "\n ast->info=~s\n" o)
978       ;; (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)))
979       ;; (stderr "  text=~a\n" text)
980       ;; (stderr "   info=~a\n" info)
981       ;; (stderr "   globals=~a\n" globals)
982       (pmatch o
983         (((trans-unit . _) . _)
984          ((ast-list->info info)  o))
985         ((trans-unit . ,elements)
986          ((ast-list->info info) elements))
987         ((fctn-defn . _) ((function->info info) o))
988         ((comment . _) info)
989         ((cpp-stmt (define (name ,name) (repl ,value)))
990          info)
991
992         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
993          info)
994
995         ;; FIXME: expr-stmt wrapper?
996         (trans-unit info)
997         ((expr-stmt) info)
998         ((assn-expr . ,assn-expr)
999          ((ast->info info) `(expr-stmt ,o)))
1000
1001         ((d-sel . ,d-sel)
1002          (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1003            expr))
1004
1005         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1006         
1007         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1008          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1009                                    (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1010              (let* ((globals (append globals (filter-map expr->global expr-list)))
1011                     (info (clone info #:globals globals))
1012                     (args (map (expr->arg info) expr-list)))
1013                (if ;;#t ;;(assoc-ref globals name)
1014                 (not (equal? name "functionx"))
1015                 (clone info #:text
1016                        (append text
1017                                (list (lambda (f g ta t d)
1018                                        (apply i386:call (cons* f g ta t d
1019                                                                (+ t (function-offset name f)) args)))))
1020                        #:globals globals)
1021                 (let* ((empty (clone info #:text '()))
1022                        ;;(accu ((ident->accu info) name))
1023                        (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1024                   (stderr "DINGES: ~a\n" o)
1025                   (clone info #:text
1026                          (append text
1027                                  (list (lambda (f g ta t d)
1028                                          '(#x90)))
1029                                  ;;accu
1030                                  (.text accu)
1031                                  (list (lambda (f g ta t d)
1032                                          '(#x90)))
1033                                  (list (lambda (f g ta t d)
1034                                          (apply i386:call-accu (cons* f g ta t d args)))))
1035                          #:globals globals))))))
1036
1037         ;;((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))))
1038         ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1039          (let* ((globals (append globals (filter-map expr->global expr-list)))
1040                     (info (clone info #:globals globals))
1041                     (args (map (expr->arg info) expr-list))
1042                     (empty (clone info #:text '()))
1043                     (accu ((expr->accu empty) function)))
1044            (clone info #:text
1045                   (append text
1046                           (list (lambda (f g ta t d)
1047                                   '(#x90)))
1048                           (.text accu)
1049                           (list (lambda (f g ta t d)
1050                                   '(#x90)))
1051                           (list (lambda (f g ta t d)
1052                                   (apply i386:call-accu (cons* f g ta t d args)))))
1053                   #:globals globals)))
1054
1055         ((if ,test ,body)
1056          (let* ((text-length (length text))
1057
1058                 (test-jump->info ((test->jump->info info) test))
1059                 (test+jump-info (test-jump->info 0))
1060                 (test-length (length (.text test+jump-info)))
1061
1062                 (body-info ((ast->info test+jump-info) body))
1063                 (text-body-info (.text body-info))
1064                 (body-text (list-tail text-body-info test-length))
1065                 (body-length (length (text->list body-text)))
1066
1067                 (text+test-text (.text (test-jump->info body-length)))
1068                 (test-text (list-tail text+test-text text-length)))
1069
1070            (clone info #:text
1071                   (append text
1072                           test-text
1073                           body-text)
1074                   #:globals (.globals body-info))))
1075
1076         ((if ,test ,then ,else)
1077          (let* ((text-length (length text))
1078
1079                 (test-jump->info ((test->jump->info info) test))
1080                 (test+jump-info (test-jump->info 0))
1081                 (test-length (length (.text test+jump-info)))
1082
1083                 (then-info ((ast->info test+jump-info) then))
1084                 (text-then-info (.text then-info))
1085                 (then-text (list-tail text-then-info test-length))
1086                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1087                 (then-jump-length (length (text->list then-jump-text)))
1088                 (then-length (+ (length (text->list then-text)) then-jump-length))
1089
1090                 (else-info ((ast->info test+jump-info) else))
1091                 (text-else-info (.text else-info))
1092                 (else-text (list-tail text-else-info test-length))
1093                 (else-length (length (text->list else-text)))
1094
1095                 (text+test-text (.text (test-jump->info (+ then-length then-jump-length))))
1096                 (test-text (list-tail text+test-text text-length))
1097                 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1098
1099            (clone info #:text
1100                   (append text
1101                           test-text
1102                           then-text
1103                           then-jump-text
1104                           else-text)
1105                   #:globals (.globals then-info)))) ;; FIXME: else-globals
1106
1107         ((expr-stmt (cond-expr ,test ,then ,else))
1108          (let* ((text-length (length text))
1109
1110                 (test-jump->info ((test->jump->info info) test))
1111                 (test+jump-info (test-jump->info 0))
1112                 (test-length (length (.text test+jump-info)))
1113
1114                 (then-info ((ast->info test+jump-info) then))
1115                 (text-then-info (.text then-info))
1116                 (then-text (list-tail text-then-info test-length))
1117                 (then-length (length (text->list then-text)))
1118
1119                 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1120                 (jump-length (length (text->list jump-text)))
1121
1122                 (test+then+jump-info
1123                  (clone then-info
1124                         #:text (append (.text then-info) jump-text)))
1125
1126                 (else-info ((ast->info test+then+jump-info) else))
1127                 (text-else-info (.text else-info))
1128                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1129                 (else-length (length (text->list else-text)))
1130
1131                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1132                 (test-text (list-tail text+test-text text-length))
1133                 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1134
1135            (clone info #:text
1136                   (append text
1137                           test-text
1138                           then-text
1139                           jump-text
1140                           else-text)
1141                   #:globals (.globals else-info))))
1142
1143         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1144          (let* ((expr ((expr->accu info) expr))
1145                 (empty (clone info #:text '()))
1146                 (case-infos (map (case->jump-info empty) cases))
1147                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1148                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1149                               (if (null? cases) info
1150                                   (let ((c-j ((case->jump-info info) (car cases))))
1151                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1152            cases-info))
1153
1154         ((for ,init ,test ,step ,body)
1155          (let* ((info (clone info #:text '()))
1156
1157                 (info ((ast->info info) init))
1158
1159                 (init-text (.text info))
1160                 (init-locals (.locals info))
1161                 (info (clone info #:text '()))
1162
1163                 (body-info ((ast->info info) body))
1164                 (body-text (.text body-info))
1165                 (body-length (length (text->list body-text)))
1166
1167                 (step-info ((ast->info info) `(expr-stmt ,step)))
1168                 (step-text (.text step-info))
1169                 (step-length (length (text->list step-text)))
1170
1171                 (test-jump->info ((test->jump->info info) test))
1172                 (test+jump-info (test-jump->info 0))
1173                 (test-length (length (text->list (.text test+jump-info))))
1174
1175                 (skip-body-text (list (lambda (f g ta t d)
1176                                         (i386:Xjump (+ body-length step-length)))))
1177
1178                 (jump-text (list (lambda (f g ta t d)
1179                                    (i386:Xjump (- (+ body-length step-length test-length))))))
1180                 (jump-length (length (text->list jump-text)))
1181
1182                 (test-text (.text (test-jump->info jump-length))))
1183
1184            (clone info #:text
1185                   (append text
1186                           init-text
1187                           skip-body-text
1188                           body-text
1189                           step-text
1190                           test-text
1191                           jump-text)
1192                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1193                   #:locals locals)))
1194
1195         ((while ,test ,body)
1196          (let* ((info (clone info #:text '()))
1197                 (body-info ((ast->info info) body))
1198                 (body-text (.text body-info))
1199                 (body-length (length (text->list body-text)))
1200
1201                 (test-jump->info ((test->jump->info info) test))
1202                 (test+jump-info (test-jump->info 0))
1203                 (test-length (length (text->list (.text test+jump-info))))
1204
1205                 (skip-body-text (list (lambda (f g ta t d)
1206                                         (i386:Xjump body-length))))
1207                 (jump-text (list (lambda (f g ta t d)
1208                                    (i386:Xjump (- (+ body-length test-length))))))
1209                 (jump-length (length (text->list jump-text)))
1210
1211                 (test-text (.text (test-jump->info jump-length))))
1212
1213            (clone info #:text
1214                   (append text
1215                           skip-body-text
1216                           body-text
1217                           test-text
1218                           jump-text)
1219                   #:globals (.globals body-info))))
1220
1221         ((labeled-stmt (ident ,label) ,statement)
1222          (let ((info (clone info #:text (append text (list label)))))
1223            ((ast->info info) statement)))
1224
1225         ((goto (ident ,label))
1226          (let ((offset (length (text->list text)))
1227                (jump (lambda (n) (i386:Xjump n))))
1228            (clone info #:text
1229                   (append text
1230                           (list (lambda (f g ta t d)
1231                                   (jump (- (label-offset (.function info) label f) offset (length (jump 0))))))))))
1232
1233         ;;; FIXME: only zero?!
1234         ((p-expr (ident ,name))
1235          (clone info #:text
1236                 (append text
1237                         ((ident->accu info) name)
1238                         (list (lambda (f g ta t d)
1239                                 (append
1240                                  (i386:accu-zero?)))))))
1241
1242         ((p-expr (fixed ,value))
1243          (let ((value (cstring->number value)))
1244           (clone info #:text
1245                  (append text
1246                          (list (lambda (f g ta t d)
1247                                  (append
1248                                   (i386:value->accu value)
1249                                   (i386:accu-zero?))))))))
1250
1251         ((de-ref (p-expr (ident ,name)))
1252          (clone info #:text
1253                 (append text
1254                         ((ident->accu info) name)
1255                         (list (lambda (f g ta t d)
1256                                 (append
1257                                  (i386:byte-mem->accu)))))))
1258
1259         ((fctn-call . ,call)
1260          (let ((info ((ast->info info) `(expr-stmt ,o))))
1261            (clone info #:text
1262                   (append (.text info)
1263                           (list (lambda (f g ta t d)
1264                                   (i386:accu-zero?)))))))
1265
1266         ;; FIXME
1267         ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1268         ((post-inc (p-expr (ident ,name)))
1269          (clone info #:text
1270                 (append text
1271                         ((ident->accu info) name)
1272                         ((ident-add info) name 1)
1273                         (list (lambda (f g ta t d)
1274                                 (append
1275                                  (i386:accu-zero?)))))))
1276         ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1277         ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1278         ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1279         ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1280
1281         ;; i++
1282         ((expr-stmt (post-inc (p-expr (ident ,name))))
1283          (clone info #:text (append text ((ident-add info) name 1))))
1284
1285         ;; ++i
1286         ((expr-stmt (pre-inc (p-expr (ident ,name))))
1287          (or (assoc-ref locals name) barf)
1288          (clone info #:text
1289                 (append text
1290                         ((ident-add info) name 1)
1291                         ((ident->accu info) name)
1292                         (list (lambda (f g ta t d)
1293                                 (append
1294                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1295                                  (i386:accu-zero?)))))))
1296
1297         ;; i--
1298         ((expr-stmt (post-dec (p-expr (ident ,name))))
1299          (or (assoc-ref locals name) barf)
1300          (clone info #:text
1301                 (append text
1302                         ((ident->accu info) name)
1303                         ((ident-add info) name -1)
1304                         (list (lambda (f g ta t d)
1305                                 (append
1306                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1307                                  (i386:accu-zero?)))))))
1308
1309         ;; --i
1310         ((expr-stmt (pre-dec (p-expr (ident ,name))))
1311          (or (assoc-ref locals name) barf)
1312          (clone info #:text
1313                 (append text
1314                         ((ident-add info) name -1)
1315                         ((ident->accu info) name)
1316                         (list (lambda (f g ta t d)
1317                                 (append
1318                                  ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1319                                  ;;(i386:local->accu (local:id (assoc-ref locals name)))
1320                                  (i386:accu-zero?)))))))
1321
1322         ((not ,expr)
1323          (let* ((test-info ((ast->info info) expr)))
1324            (clone info #:text
1325                   (append (.text test-info)
1326                           (list (lambda (f g ta t d)
1327                                   (append
1328                                    (i386:accu-not)
1329                                    (i386:accu-zero?)))))
1330                   #:globals (.globals test-info))))
1331
1332         ((eq ,a ,b)
1333          (let* ((base ((expr->base info) a))
1334                 (empty (clone base #:text '()))
1335                 (accu ((expr->accu empty) b)))
1336            (clone info #:text
1337                   (append text
1338                           (.text base)
1339                           (.text accu)
1340                           (list (lambda (f g ta t d)
1341                                   (i386:sub-base)))))))
1342
1343         ((gt ,a ,b)
1344          (let* ((base ((expr->base info) a))
1345                 (empty (clone base #:text '()))
1346                 (accu ((expr->accu empty) b)))
1347            (clone info #:text
1348                   (append text
1349                           (.text base)
1350                           (.text accu)
1351                           (list (lambda (f g ta t d)
1352                                   (i386:sub-base)))))))
1353
1354         ((ne ,a ,b)
1355          (let* ((base ((expr->base info) a))
1356                 (empty (clone base #:text '()))
1357                 (accu ((expr->accu empty) b)))
1358            (clone info #:text
1359                   (append text
1360                           (.text base)
1361                           (.text accu)
1362                           (list (lambda (f g ta t d)
1363                                   (append 
1364                                    (i386:sub-base)
1365                                    (i386:xor-zf))))))))
1366
1367         ((lt ,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                                   (i386:base-sub)))))))
1377
1378         ;; TODO: byte dinges
1379         ((Xsub ,a ,b)
1380          (let* ((base ((expr->base info) a))
1381                 (empty (clone base #:text '()))
1382                 (accu ((expr->accu empty) b)))
1383            (clone info #:text
1384                   (append text
1385                           (.text base)
1386                           (.text accu)
1387                           (list (lambda (f g ta t d)
1388                                   (i386:base-sub)))))))
1389
1390         ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1391          (clone info #:text
1392                 (append text
1393                         (list (lambda (f g ta t d)
1394                                 (append
1395                                  (i386:local->accu (local:id (assoc-ref locals a)))
1396                                  (i386:byte-mem->base)
1397                                  (i386:local->accu (local:id (assoc-ref locals b)))
1398                                  (i386:byte-mem->accu)
1399                                  (i386:byte-sub-base)))))))
1400
1401         ;; g_cells[0]
1402         ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,array)))
1403          (let ((value (cstring->number value)))
1404            (clone info #:text
1405                   (append text
1406                         ((ident->base info) array)
1407                         (list (lambda (f g ta t d)
1408                                 (append
1409                                  (i386:value->accu value)
1410                                  ;;(i386:byte-base-mem->accu)
1411                                  (i386:base-mem->accu)
1412                                  ))))))) ; FIXME: type: char
1413         
1414         ;; g_cells[a]
1415         ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1416          (clone info #:text
1417                 (append text
1418                         ((ident->base info) index)  ;; FIXME: chars! index*size
1419                         ((ident->accu info) array)
1420                         (list (lambda (f g ta t d)
1421                                 ;;(i386:byte-base-mem->accu)
1422                                 (i386:base-mem->accu)
1423                                 ))))) ; FIXME: type: char
1424         
1425         ((return ,expr)
1426          (let ((accu ((expr->accu info) expr)))
1427            (clone accu #:text
1428                   (append (.text accu) (list (i386:ret (lambda _ '())))))))
1429
1430         ;; int i;
1431         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1432          (if (.function info)
1433              (clone info #:locals (add-local locals name type 0))
1434              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1435
1436         ;; int i = 0;
1437         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1438          (let ((value (cstring->number value)))
1439            (if (.function info)
1440                (let* ((locals (add-local locals name type 0))
1441                       (info (clone info #:locals locals)))
1442                  (clone info #:text
1443                         (append text
1444                                 ((value->ident info) name value))))
1445                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1446
1447         ;; char c = 'A';
1448         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1449          (if (not (.function info)) decl-barf0)
1450          (let* ((locals (add-local locals name type 0))
1451                 (info (clone info #:locals locals))
1452                 (value (char->integer (car (string->list value)))))
1453            (clone info #:text
1454                   (append text
1455                           ((value->ident info) name value)))))
1456
1457         ;; int i = -1;
1458         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1459          (if (not (.function info)) decl-barf1)
1460          (let* ((locals (add-local locals name type 0))
1461                 (info (clone info #:locals locals))
1462                 (value (- (cstring->number value))))
1463            (clone info #:text
1464                   (append text
1465                           ((value->ident info) name value)))))
1466
1467         ;; int i = argc;
1468         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1469          (if (not (.function info)) decl-barf2)
1470          (let* ((locals (add-local locals name type 0))
1471                 (info (clone info #:locals locals)))
1472            (clone info #:text
1473                   (append text
1474                           ((ident->accu info) local)
1475                           ((accu->ident info) name)))))
1476
1477         ;; char *p = "t.c";
1478         ;;(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"))))))
1479         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
1480          (if (not (.function info)) decl-barf3)
1481          (let* ((locals (add-local locals name type 1))
1482                 (globals (append globals (list (string->global value))))
1483                 (info (clone info #:locals locals #:globals globals)))
1484            (clone info #:text
1485                   (append text
1486                           (list (lambda (f g ta t d)
1487                                   (append
1488                                    (i386:global->accu (+ (data-offset value g) d)))))
1489                           ((accu->ident info) name)))))
1490         
1491         ;; char arena[20000];
1492         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1493          (let ((type (ast->type type)))
1494            (if (.function info)
1495                TODO:decl-array 
1496                (let* ((globals (.globals info))
1497                       (count (cstring->number count))
1498                       (size (type->size info type))
1499                       ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1500                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1501                       (globals (append globals (list array))))
1502                  (clone info
1503                         #:globals globals)))))
1504
1505         ;;struct scm *g_cells = (struct scm*)arena;
1506         ((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)))))))
1507          ;;(stderr "0TYPE: ~s\n" type)
1508          (if (.function info)
1509              (let* ((locals (add-local locals name type 1))
1510                     (info (clone info #:locals locals)))
1511                (clone info #:text
1512                       (append text
1513                               ((ident->accu info) name)
1514                               ((accu->ident info) value)))) ;; FIXME: deref?
1515              (let* ((globals (append globals (list (ident->global name type 1 0))))
1516                     (info (clone info #:globals globals)))
1517                (clone info #:text
1518                       (append text
1519                               ((ident->accu info) name)
1520                               ((accu->ident info) value)))))) ;; FIXME: deref?
1521
1522         ;; SCM tmp;
1523         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1524          ;;(stderr  "1TYPE: ~s\n" type)
1525          (if (.function info)
1526              (clone info #:locals (add-local locals name type 0))
1527              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1528
1529         ;; SCM g_stack = 0;
1530         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1531          ;;(stderr  "2TYPE: ~s\n" type)
1532          (if (.function info)
1533              (let* ((locals (add-local locals name type 0))
1534                     (globals (append globals (list (string->global value))))
1535                     (info (clone info #:locals locals #:globals globals)))
1536                (clone info #:text
1537                       (append text
1538                               (list (lambda (f g ta t d)
1539                                       (append
1540                                        (i386:global->accu (+ (data-offset value g) d)))))
1541                               ((accu->ident info) name))))
1542              (let* ((value (length (globals->data globals)))
1543                     (globals (append globals (list (ident->global name type 0 value)))))
1544                (clone info #:globals globals))))
1545
1546         ;; SCM g_stack = 0; // comment
1547         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1548          ((ast->info info) (list-head o (- (length o) 1))))
1549
1550         ;; SCM i = argc;
1551         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1552          ;;(stderr  "3TYPE: ~s\n" type)
1553          (if (.function info)
1554              (let* ((locals (add-local locals name type 0))
1555                     (info (clone info #:locals locals)))
1556                (clone info #:text
1557                       (append text
1558                               ((ident->accu info) local)
1559                               ((accu->ident info) name))))
1560              (let* ((globals (append globals (list (ident->global name type 0 0))))
1561                     (info (clone info #:globals globals)))
1562                (clone info #:text
1563                       (append text
1564                               ((ident->accu info) local)
1565                               ((accu->ident info) name))))))
1566
1567         ;; int i = f ();
1568         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1569          ;;(stderr  "4TYPE: ~s\n" type)
1570          (let* ((locals (add-local locals name type 0))
1571                 (info (clone info #:locals locals)))
1572            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1573              (clone info
1574                     #:text
1575                     (append (.text info)
1576                             ((accu->ident info) name))
1577                     #:locals locals))))
1578         
1579         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1580         ((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))))
1581          (let* ((locals (add-local locals name type 1))
1582                 (info (clone info #:locals locals))
1583                 (empty (clone info #:text '()))
1584                 (accu ((expr->accu empty) initzer)))
1585            (clone info
1586                   #:text
1587                   (append text
1588                           (.text accu)
1589                           ((accu->ident info) name)
1590                           (list (lambda (f g ta t d)
1591                                   (append
1592                                    ;;(i386:value->base t)
1593                                    ;;(i386:accu+base)
1594                                    (i386:value->base ta)
1595                                    (i386:accu+base)))))
1596                   #:locals locals)))
1597
1598         ;; SCM x = car (e);
1599         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1600          ;;(stderr  "5TYPE: ~s\n" type)
1601          (let* ((locals (add-local locals name type 0))
1602                 (info (clone info #:locals locals)))
1603            (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1604              (clone info
1605                     #:text
1606                     (append (.text info)
1607                             ((accu->ident info) name))))))
1608
1609         ;; char *p = (char*)g_cells;
1610         ((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)))))))
1611          ;;(stderr  "6TYPE: ~s\n" type)
1612          (if (.function info)
1613              (let* ((locals (add-local locals name type 1))
1614                     (info (clone info #:locals locals)))
1615                (clone info #:text
1616                       (append text
1617                               ((ident->accu info) value)
1618                               ((accu->ident info) name))))
1619              (let* ((globals (append globals (list (ident->global name type 1 0))))
1620                     (here (data-offset name globals))
1621                     (there (data-offset value globals)))
1622                (clone info
1623                       #:globals globals
1624                       #:init (append (.init info)
1625                                      (list (lambda (functions globals ta t d data)
1626                                              (append
1627                                               (list-head data here)
1628                                               ;;; FIXME: type
1629                                               ;;; char *x = arena;
1630                                               (int->bv32 (+ d (data-offset value globals)))
1631                                               ;;; char *y = x;
1632                                               ;;;(list-head (list-tail data there) 4)
1633                                               (list-tail data (+ here 4))))))))))
1634
1635         ;; char *p = g_cells;
1636         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1637          ;;(stderr  "7TYPE: ~s\n" type)
1638          (let ((type (decl->type type)))
1639            ;;(stderr "0DECL: ~s\n" type)
1640            (if (.function info)
1641                (let* ((locals (add-local locals name type  1))
1642                       (info (clone info #:locals locals)))
1643                  (clone info #:text
1644                         (append text
1645                                 ((ident->accu info) value)
1646                                 ((accu->ident info) name))))
1647                (let* ((globals (append globals (list (ident->global name type 1 0))))
1648                       (here (data-offset name globals))
1649                       (there (data-offset value globals)))
1650                  (clone info
1651                         #:globals globals
1652                         #:init (append (.init info)
1653                                        (list (lambda (functions globals ta t d data)
1654                                                (append
1655                                                 (list-head data here)
1656                                               ;;; FIXME: type
1657                                               ;;; char *x = arena;p
1658                                                 (int->bv32 (+ d (data-offset value globals)))
1659                                               ;;; char *y = x;
1660                                               ;;;(list-head (list-tail data there) 4)
1661                                                 (list-tail data (+ here 4)))))))))))
1662
1663         ;; enum 
1664         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1665          (let ((type (enum->type name fields))
1666                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1667            (clone info
1668                   #:types (append (.types info) (list type))
1669                   #:constants (append constants (.constants info)))))
1670
1671         ;; struct
1672         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1673          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1674            (stderr "type: ~a\n" type)
1675            (clone info #:types (append (.types info) (list type)))))
1676
1677         ;; *p++ = b;
1678         ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
1679          (when (not (equal? op "="))
1680            (stderr "OOOPS0.0: op=~s\n" op)
1681            barf)
1682          (let* ((empty (clone info #:text '()))
1683                 (base ((expr->base empty) b)))
1684            (clone info #:text
1685                   (append text
1686                           (.text base)
1687                           ((base->ident-address info) name)
1688                           ((ident-add info) name 1)))))
1689
1690         ;; CAR (x) = 0
1691         ;; TYPE (x) = PAIR;
1692         ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
1693          (when (not (equal? op "="))
1694            (stderr "OOOPS0: op=~s\n" op)
1695            barf)
1696          (let* ((empty (clone info #:text '()))
1697                 (expr ((expr->Xaccu empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
1698                 (base ((expr->base empty) b))
1699                 (type (list "struct" "scm")) ;; FIXME
1700                 (fields (type->description info type))
1701                 (size (type->size info type))
1702                 (field-size 4) ;; FIXME:4, not fixed
1703                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
1704            (clone info #:text (append text
1705                                       (.text expr)
1706                                       (list (lambda (f g ta t d)
1707                                               '(#x90)))
1708                                       (.text base)
1709                                       (list (lambda (f g ta t d)
1710                                               '(#x90)))
1711                                       (list (lambda (f g ta t d)
1712                                               ;;(i386:byte-base->accu-ref) ;; FIXME: size
1713                                               (i386:base->accu-address)
1714                                               ))))))
1715
1716
1717         ;; i = 0;
1718         ;; c = f ();
1719         ;; i = i + 48;
1720         ;; p = g_cell;
1721         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
1722          (when (and (not (equal? op "="))
1723                     (not (equal? op "+="))
1724                     (not (equal? op "-=")))
1725            (stderr "OOOPS1: op=~s\n" op)
1726            barf)
1727          (let* ((empty (clone info #:text '()))
1728                 (base ((expr->base empty) b)))
1729            (clone info #:text (append text
1730                                       (.text base)
1731                                       (if (equal? op "=") '()
1732                                           (append ((ident->accu info) name)
1733                                                   (list (lambda (f g ta t d)
1734                                                           (append
1735                                                            (if (equal? op "+=")
1736                                                                (i386:accu+base)
1737                                                                (i386:accu-base))
1738                                                            (i386:accu->base))))))
1739                                       ;;assign:
1740                                       ((base->ident info) name)))))
1741         
1742         ;; *p = 0;
1743         ((expr-stmt (assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))
1744          (when (not (equal? op "="))
1745            (stderr "OOOPS2: op=~s\n" op)
1746            barf)
1747          (let* ((empty (clone info #:text '()))
1748                 (base ((expr->base empty) b)))
1749            (clone info #:text (append text
1750                                       (.text base)
1751                                       ;;assign:
1752                                       ((base->ident-address info) name)))))
1753
1754         ;; g_cells[0] = 65;
1755         ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op ,op) ,b))
1756          (when (not (equal? op "="))
1757            (stderr "OOOPS3: op=~s\n" op)
1758            barf)
1759          (let* ((index (cstring->number index))
1760                 (empty (clone info #:text '()))
1761                 (base ((expr->base empty) b)))
1762           (clone info #:text
1763                  (append text
1764                          (.text base)
1765
1766                          (list (lambda (f g ta t d)
1767                                  (i386:push-base)))
1768                          ((ident->base info) name)
1769                          (list (lambda (f g ta t d)
1770                                  (append
1771                                   (i386:value->accu index)
1772                                   (i386:accu+base))))
1773                          (list (lambda (f g ta t d)
1774                                  (i386:pop-base)))
1775
1776                          (list (lambda (f g ta t d)
1777                                  (i386:base->accu-address)))))))
1778
1779         ;; g_cells[i] = c;
1780         ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,name))) (op ,op) ,b))
1781          (when (not (equal? op "="))
1782            (stderr "OOOPS4: op=~s\n" op)
1783            barf)
1784          (let* ((empty (clone info #:text '()))
1785                 (base ((expr->base empty) b)))
1786            (clone info #:text
1787                   (append text
1788                           (.text base)
1789
1790                          (list (lambda (f g ta t d)
1791                                  (i386:push-base)))
1792                           ((ident->base info) name)
1793                           ((ident->accu info) index)  ;; FIXME: chars! index*size
1794                           (list (lambda (f g ta t d)
1795                                   (i386:accu+base))) ; FIXME: type: char
1796                          (list (lambda (f g ta t d)
1797                                  (i386:pop-base)))
1798
1799                           (list (lambda (f g ta t d)
1800                                   ;;(i386:byte-base->accu-address)
1801                                   (i386:base->accu-address)
1802                                   ))))))
1803
1804         ;; g_functions[g_function++] = g_foo;
1805         ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,name))) (op ,op) ,b))
1806          (when (not (equal? op "="))
1807            (stderr "OOOPS5: op=~s\n" op)
1808            barf)
1809          (let* ((empty (clone info #:text '()))
1810                 (base ((expr->base empty) b)))
1811            (clone info #:text
1812                   (append text
1813                           (.text base)
1814
1815                           (list (lambda (f g ta t d)
1816                                  (i386:push-base)))
1817                           ((ident->base info) name)
1818                           ((ident->accu info) index)  ;; FIXME: chars! index*size
1819                           (list (lambda (f g ta t d)
1820                                   (i386:accu+base))) ; FIXME: type: char
1821                           (list (lambda (f g ta t d)
1822                                   (i386:pop-base)))
1823
1824                           (list (lambda (f g ta t d)
1825                                   (append
1826                                    (i386:base->accu-address))))
1827
1828                           ((ident-add info) index 1)
1829                           ))))
1830
1831         ;; DECL
1832         ;;
1833         ;; struct f = {...};
1834         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1835          (let* ((type (decl->type type))
1836                 ;;(foo (stderr "1DECL: ~s\n" type))
1837                 (fields (type->description info type))
1838                 (size (type->size info type))
1839                 (field-size 4))  ;; FIXME:4, not fixed
1840            ;;(stderr  "7TYPE: ~s\n" type)
1841            (if (.function info)
1842                (let* ((locals (let loop ((fields (cdr fields)) (locals locals))
1843                                 (if (null? fields) locals
1844                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1845                       (locals (add-local locals name type -1))
1846                       (info (clone info #:locals locals))
1847                       (empty (clone info #:text '())))
1848                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1849                    ;; (stderr "LOEP local initzers=~s\n" initzers)
1850                    (if (null? fields) info
1851                        (let ((offset (* field-size (car fields)))
1852                              (initzer (car initzers)))
1853                          (loop (cdr fields) (cdr initzers)
1854                                (clone info #:text
1855                                       (append
1856                                        (.text info)
1857                                        ((ident->accu info) name)
1858                                        (list (lambda (f g ta t d)
1859                                                (append
1860                                                 (i386:accu->base))))
1861                                        (.text ((expr->accu empty) initzer))
1862                                        (list (lambda (f g ta t d)
1863                                                (i386:accu->base-address+n offset))))))))))
1864                (let* ((global (make-global name type -1 (string->list (make-string size #\nul))))
1865                       (globals (append globals (list global)))
1866                       (here (data-offset name globals))
1867                       (info (clone info #:globals globals))
1868                       (field-size 4))
1869                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1870                    ;; (stderr "LOEP local initzers=~s\n" initzers)
1871                    (if (null? fields) info
1872                        (let ((offset (* field-size (car fields)))
1873                              (initzer (car initzers)))
1874                          (loop (cdr fields) (cdr initzers)
1875                                (clone info #:init
1876                                       (append
1877                                        (.init info)
1878                                        (list (lambda (functions globals ta t d data)
1879                                                (append
1880                                                 (list-head data (+ here offset))
1881                                                 (initzer->data info functions globals ta t d (car initzers))
1882                                                 (list-tail data (+ here offset field-size)))))))))))))))
1883
1884         ((decl . _)
1885          (format (current-error-port) "SKIP: decl statement=~s\n" o)
1886          info)
1887
1888         (_
1889          (format (current-error-port) "SKIP: statement=~s\n" o)
1890          barf
1891          info)))))
1892
1893 (define (initzer->data info functions globals ta t d o)
1894   (pmatch o
1895     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1896     ((initzer (ref-to (p-expr (ident ,name))))
1897      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
1898      (int->bv32 (+ ta (function-offset name functions))))
1899     ((initzer (p-expr (ident ,name)))
1900      (let ((value (assoc-ref (.constants info) name)))
1901        (int->bv32 value)))
1902     (_ (stderr "initzer->data:SKIP: ~s\n" o)
1903        barf
1904      (int->bv32 0))))
1905
1906 (define (info->exe info)
1907   (display "dumping elf\n" (current-error-port))
1908   (map write-any (make-elf (.functions info) (.globals info) (.init info))))
1909
1910 (define (.formals o)
1911   (pmatch o
1912     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1913     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1914     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
1915        barf)))
1916
1917 (define (formal->text n)
1918   (lambda (o i)
1919     ;;(i386:formal i n)
1920     '()
1921     ))
1922
1923 (define (formals->text o)
1924   (pmatch o
1925     ((param-list . ,formals)
1926      (let ((n (length formals)))
1927        (list (lambda (f g ta t d)
1928                (append
1929                 (i386:function-preamble)
1930                 (append-map (formal->text n) formals (iota n))
1931                 (i386:function-locals))))))
1932     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
1933        barf)))
1934
1935 (define (formals->locals o)
1936   (pmatch o
1937     ((param-list . ,formals)
1938      (let ((n (length formals)))
1939        (map make-local (map .name formals) (map .type formals) (make-list n 0) (iota n -2 -1))))
1940     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
1941        barf)))
1942
1943 (define (function->info info)
1944   (lambda (o)
1945     ;;(stderr "\n")
1946     ;;(stderr "formals=~a\n" (.formals o))
1947     (let* ((name (.name o))
1948            (text (formals->text (.formals o)))
1949            (locals (formals->locals (.formals o))))
1950       (format (current-error-port) "compiling ~a\n" name)
1951       ;;(stderr "locals=~a\n" locals)
1952       (let loop ((statements (.statements o))
1953                  (info (clone info #:locals locals #:function name #:text text)))
1954         (if (null? statements) (clone info
1955                                       #:function #f
1956                                       #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
1957             (let* ((statement (car statements)))
1958               (loop (cdr statements)
1959                     ((ast->info info) (car statements)))))))))
1960
1961 (define (ast-list->info info)
1962   (lambda (elements)
1963     (let loop ((elements elements) (info info))
1964       (if (null? elements) info
1965           (loop (cdr elements) ((ast->info info) (car elements)))))))
1966
1967 (define _start
1968   (let* ((argc-argv
1969           (string-append ".byte"
1970                          " 0x89 0xe8"      ; mov    %ebp,%eax
1971                          " 0x83 0xc0 0x08" ; add    $0x8,%eax
1972                          " 0x50"           ; push   %eax
1973                          " 0x89 0xe8"      ; mov    %ebp,%eax
1974                          " 0x83 0xc0 0x04" ; add    $0x4,%eax
1975                          " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
1976                          " 0x50"           ; push   %eax
1977                          ))
1978          (ast (with-input-from-string
1979                   
1980                   (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
1981                 parse-c99)))
1982     ast))
1983
1984 (define strlen
1985   (let* ((ast (with-input-from-string
1986                   "
1987 int
1988 strlen (char const* s)
1989 {
1990   int i = 0;
1991   while (s[i]) i++;
1992   return i;
1993 }
1994 "
1995 ;;paredit:"
1996                 parse-c99)))
1997     ast))
1998
1999 (define getchar
2000   (let* ((ast (with-input-from-string
2001                   "
2002 int
2003 getchar ()
2004 {
2005   char c1;
2006   int r = read (g_stdin, &c1, 1);
2007   //int r = read (0, &c1, 1);
2008   if (r < 1) return -1;
2009   return c1;
2010 }
2011 "
2012 ;;paredit:"
2013                 parse-c99)))
2014     ast))
2015
2016 (define putchar
2017   (let* ((ast (with-input-from-string
2018                   "
2019 int
2020 putchar (int c)
2021 {
2022   //write (STDOUT, s, strlen (s));
2023   //int i = write (STDOUT, s, strlen (s));
2024   write (1, (char*)&c, 1);
2025   return 0;
2026 }
2027 "
2028 ;;paredit:"
2029                 parse-c99)))
2030     ast))
2031
2032 (define eputs
2033   (let* ((ast (with-input-from-string
2034                   "
2035 int
2036 eputs (char const* s)
2037 {
2038   //write (STDERR, s, strlen (s));
2039   //write (2, s, strlen (s));
2040   int i = strlen (s);
2041   write (2, s, i);
2042   return 0;
2043 }
2044 "
2045 ;;paredit:"
2046                 parse-c99)))
2047     ast))
2048
2049 (define fputs
2050   (let* ((ast (with-input-from-string
2051                   "
2052 int
2053 fputs (char const* s, int fd)
2054 {
2055   int i = strlen (s);
2056   write (fd, s, i);
2057   return 0;
2058 }
2059 "
2060 ;;paredit:"
2061                 parse-c99)))
2062     ast))
2063
2064 (define puts
2065   (let* ((ast (with-input-from-string
2066                   "
2067 int
2068 puts (char const* s)
2069 {
2070   //write (STDOUT, s, strlen (s));
2071   //int i = write (STDOUT, s, strlen (s));
2072   int i = strlen (s);
2073   write (1, s, i);
2074   return 0;
2075 }
2076 "
2077 ;;paredit:"
2078                 parse-c99)))
2079     ast))
2080
2081 (define strcmp
2082   (let* ((ast (with-input-from-string
2083                   "
2084 int
2085 strcmp (char const* a, char const* b)
2086 {
2087   while (*a && *b && *a == *b) 
2088     {
2089       a++;b++;
2090     }
2091   return *a - *b;
2092 }
2093 "
2094 ;;paredit:"
2095                 parse-c99)))
2096     ast))
2097
2098 (define i386:libc
2099   (list
2100    (cons "exit" (list i386:exit))
2101    (cons "open" (list i386:open))
2102    (cons "read" (list i386:read))
2103    (cons "write" (list i386:write))))
2104
2105 (define libc
2106   (list
2107    strlen
2108    getchar
2109    putchar
2110    eputs
2111    fputs
2112    puts
2113    strcmp))
2114
2115 (define (compile)
2116   (let* ((ast (mescc))
2117          (info (make <info>
2118                  #:functions i386:libc
2119                  #:types i386:type-alist))
2120          (ast (append libc ast))
2121          (info ((ast->info info) ast))
2122          (info ((ast->info info) _start)))
2123     (info->exe info)))