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