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