e655aa21b36285d4c45b755b76a16b6b2c36fb05
[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 (p-expr (ident ,name)) ,b)
596          (let* ((empty (clone info #:text '()))
597                 (base ((expr->base empty) b)))
598            (append-text info (append (.text base)
599                                      ((ident->accu info) name)
600                                      (wrap-as (i386:accu+base))))))
601
602         ((add ,a ,b)
603          (let* ((empty (clone info #:text '()))
604                 (accu ((expr->accu empty) a))
605                 (base ((expr->base empty) b)))
606            (append-text info (append (.text accu)
607                                      (.text base)
608                                      (wrap-as (i386:accu+base))))))        
609
610         ((sub ,a ,b)
611          (let* ((empty (clone info #:text '()))
612                 (accu ((expr->accu empty) a))
613                 (base ((expr->base empty) b)))
614            (append-text info (append (.text accu)
615                                      (.text base)
616                                      (wrap-as (i386:accu-base))))))        
617
618         ((bitwise-or ,a ,b)
619          (let* ((empty (clone info #:text '()))
620                 (accu ((expr->accu empty) a))
621                 (base ((expr->base empty) b)))
622            (append-text info (append (.text accu)
623                                      (.text base)
624                                      (wrap-as (i386:accu-or-base))))))
625
626         ((lshift ,a ,b)
627          (let* ((empty (clone info #:text '()))
628                 (accu ((expr->accu empty) a))
629                 (base ((expr->base empty) b)))
630            (append-text info (append (.text accu)
631                                      (.text base)
632                                      (wrap-as (i386:accu<<base))))))
633
634         ((rshift ,a ,b)
635          (let* ((empty (clone info #:text '()))
636                 (accu ((expr->accu empty) a))
637                 (base ((expr->base empty) b)))
638            (append-text info (append (.text accu)
639                                      (.text base)
640                                      (wrap-as (i386:accu>>base))))))
641
642         ((div ,a ,b)
643          (let* ((empty (clone info #:text '()))
644                 (accu ((expr->accu empty) a))
645                 (base ((expr->base empty) b)))
646            (append-text info (append (.text accu)
647                                      (.text base)
648                                      (wrap-as (i386:accu/base))))))
649
650         ((mod ,a ,b)
651          (let* ((empty (clone info #:text '()))
652                 (accu ((expr->accu empty) a))
653                 (base ((expr->base empty) b)))
654            (append-text info (append (.text accu)
655                                      (.text base)
656                                      (wrap-as (i386:accu%base))))))
657
658         ((mul ,a ,b)
659          (let* ((empty (clone info #:text '()))
660                 (accu ((expr->accu empty) a))
661                 (base ((expr->base empty) b)))
662            (append-text info (append (.text accu)
663                                      (.text base)
664                                      (wrap-as (i386:accu*base))))))
665
666         ((not ,expr)
667          (let* ((test-info ((ast->info info) expr)))
668            (clone info #:text
669                   (append (.text test-info)
670                           (wrap-as (i386:accu-not)))
671                   #:globals (.globals test-info))))
672
673         ((neg (p-expr (fixed ,value)))
674          (append-text info (value->accu (- (cstring->number value)))))
675
676         ((neg (p-expr (ident ,name)))
677          (append-text info (append ((ident->base info) name)
678                                    (wrap-as (i386:value->accu 0))
679                                    (wrap-as (i386:sub-base)))))
680
681         ((eq ,a ,b) ((compare->accu info) a b (i386:sub-base)))
682         ((ge ,a ,b) ((compare->accu info) b a (i386:sub-base)))
683         ((gt ,a ,b) ((compare->accu info) b a (i386:sub-base)))
684         ((ne ,a ,b) ((compare->accu info) a b (append (i386:sub-base)
685                                                       (i386:xor-zf))))
686         ((le ,a ,b) ((compare->accu info) b a (i386:base-sub)))
687         ((lt ,a ,b) ((compare->accu info) b a (i386:base-sub)))
688
689         ;;((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"))))))
690         ((cast ,cast ,o)
691          ((expr->accu info) o))
692
693         ;; *p++ = b;
694         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
695          (when (not (equal? op "="))
696            (stderr "OOOPS0.0: op=~s\n" op)
697            barf)
698          (let* ((empty (clone info #:text '()))
699                 (base ((expr->base empty) b)))
700            (append-text info (append (.text base)
701                                      ((base->ident-address info) name)
702                                      ((ident->accu info) name)
703                                      ((ident-add info) name 1)))))
704
705         ;; *p-- = b;
706         ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
707          (when (not (equal? op "="))
708            (stderr "OOOPS0.0: op=~s\n" op)
709            barf)
710          (let* ((empty (clone info #:text '()))
711                 (base ((expr->base empty) b)))
712            (append-text info (append (.text base)
713                                      ((base->ident-address info) name)
714                                      ((ident->accu info) name)
715                                      ((ident-add info) name -1)))))
716
717         ;; CAR (x) = 0
718         ;; TYPE (x) = PAIR;
719         ((assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b)
720          (when (not (equal? op "="))
721            (stderr "OOOPS0: op=~s\n" op)
722            barf)
723          (let* ((empty (clone info #:text '()))
724                 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
725                 (base ((expr->base empty) b))
726                 (type (list "struct" "scm")) ;; FIXME
727                 (fields (type->description info type))
728                 (size (type->size info type))
729                 (field-size 4) ;; FIXME:4, not fixed
730                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                )
731            (append-text info (append (.text expr)
732                                      (.text base)
733                                      (wrap-as (i386:base->accu-address)))))) ; FIXME: size
734
735
736         ;; i = 0;
737         ;; c = f ();
738         ;; i = i + 48;
739         ;; p = g_cell;
740         ((assn-expr (p-expr (ident ,name)) (op ,op) ,b)
741          (when (and (not (equal? op "="))
742                     (not (equal? op "+="))
743                     (not (equal? op "-=")))
744            (stderr "OOOPS1: op=~s\n" op)
745            barf)
746          (let* ((empty (clone info #:text '()))
747                 (base ((expr->base empty) b)))
748            (append-text info (append (.text base)
749                                      (if (equal? op "=") '()
750                                          (append ((ident->accu info) name)
751                                                  (wrap-as (append (if (equal? op "+=") (i386:accu+base)
752                                                                       (i386:accu-base))
753                                                                   (i386:accu->base)))))
754                                      ;;assign:
755                                      ((base->ident info) name)
756                                      (wrap-as (i386:base->accu))))))
757         
758         ;; *p = 0;
759         ((assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b)
760          (when (not (equal? op "="))
761            (stderr "OOOPS2: op=~s\n" op)
762            barf)
763          (let* ((empty (clone info #:text '()))
764                 (base ((expr->base empty) b)))
765            (append-text info (append (.text base)
766                                      ;;assign:
767                                      ((base->ident-address info) array)
768                                      (wrap-as (i386:base->accu))))))
769
770         ;; g_cells[<expr>] = <expr>;
771         ((assn-expr (array-ref ,index (p-expr (ident ,array))) (op ,op) ,b)
772          (when (not (equal? op "="))
773            (stderr "OOOPS3: op=~s\n" op)
774            barf)
775          (let* ((info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
776                 (info ((expr->+base info) b))
777                 (type (ident->type info array))
778                 (size (type->size info type))
779                 (ptr (ident->pointer info array)))
780            (append-text info (append
781                               (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
782                                   (append
783                                    (wrap-as (i386:base-address->accu-address))
784                                    (if (<= size 4) '()
785                                        (wrap-as (append (i386:accu+n 4)
786                                                         (i386:base+n 4)
787                                                         (i386:base-address->accu-address))))
788                                    (if (<= size 8) '()
789                                        (wrap-as (append (i386:accu+n 4)
790                                                         (i386:base+n 4)
791                                                         (i386:base-address->accu-address))))))))))
792
793         (_
794          (format (current-error-port) "SKIP: expr->accu=~s\n" o)
795          barf
796          info)))))
797
798 (define (expr->+base info)
799   (lambda (o)
800     (let* ((info (append-text info (wrap-as (i386:push-accu))))
801            (info ((expr->accu info) o))
802            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
803       info)))
804
805 (define (compare->accu info)
806   (lambda (a b c)
807     (let* ((info ((expr->accu info) a))
808            (info ((expr->+base info) b)))
809       (append-text info (wrap-as c)))))
810
811 (define (append-text info text)
812   (clone info #:text (append (.text info) text)))
813
814 (define (wrap-as o)
815   (list (lambda (f g ta t d) o)))
816
817 (define (expr->base info) ;; JUNKME
818   (lambda (o)
819     (let ((info ((expr->accu info) o)))
820       (clone info
821              #:text (append (wrap-as (i386:push-accu))
822                      (.text info)
823                      (wrap-as (append (i386:accu->base)
824                                       (i386:pop-accu))))))))
825
826 (define (expr->accu* info)
827   (lambda (o)
828     ;; (stderr "expr->accu* o=~s\n" o)
829
830     (pmatch o
831       ;; g_cells[<expr>]
832       ((array-ref ,index (p-expr (ident ,array)))
833        (let* ((info ((expr->accu info) index))
834               (type (ident->type info array))
835               (size (type->size info type)))
836          (append-text info (append (wrap-as (append (i386:accu->base)
837                                                     (if (eq? size 1) '()
838                                                         (append
839                                                          (if (<= size 4) '()
840                                                              (i386:accu+accu))
841                                                          (if (<= size 8) '()
842                                                              (i386:accu+base))
843                                                          (i386:accu-shl 2)))))
844                                    ((ident->base info) array)
845                                    (wrap-as (i386:accu+base))))))
846
847       ;; g_cells[10].type
848       ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
849        (let* ((type (ident->type info array))
850               (fields (or (type->description info type) '()))
851               (size (type->size info type))
852               (count (length fields))
853               (field-size 4) ;; FIXME:4, not fixed
854               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
855               (index (cstring->number index))
856               (text (.text info)))
857          (append-text info (append (wrap-as (append (i386:value->base index)
858                                                     (i386:base->accu)
859                                                     (if (<= count 1) '()
860                                                         (i386:accu+accu))
861                                                     (if (<= count 2) '()
862                                                         (i386:accu+base))
863                                                     (i386:accu-shl 2)))
864                                    ;; de-ref: g_cells, non: arena
865                                    ;;((ident->base info) array)
866                                    ((ident->base info) array)
867                                    (wrap-as (append (i386:accu+base)
868                                                     (i386:accu+value offset)))))))
869
870       ;; g_cells[x].type
871       ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
872        (let* ((type (ident->type info array))
873               (fields (or (type->description info type) '()))
874               (size (type->size info type))
875               (count (length fields))
876               (field-size 4) ;; FIXME:4, not fixed
877               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
878               (text (.text info)))
879          (append-text info (append ((ident->base info) index)
880                                    (wrap-as (append (i386:base->accu)
881                                                     (if (<= count 1) '()
882                                                         (i386:accu+accu))
883                                                     (if (<= count 2) '()
884                                                         (i386:accu+base))
885                                                     (i386:accu-shl 2)))
886                                    ;; de-ref: g_cells, non: arena
887                                    ;;((ident->base info) array)
888                                    ((ident->base info) array)
889                                    (wrap-as (append (i386:accu+base)
890                                                     (i386:accu+value offset)))))))
891
892       ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
893       ((d-sel (ident ,field) (p-expr (ident ,name)))
894        (let* ((type (ident->type info name))
895               (fields (or (type->description info type) '()))
896               (field-size 4) ;; FIXME
897               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
898               (text (.text info)))
899          (append-text info (append ((ident->accu info) name)
900                                    (wrap-as (i386:accu+value offset))))))
901
902       (_
903        (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
904        barf
905        info)
906       )))
907
908 (define (ident->constant name value)
909   (cons name value))
910
911 (define (make-type name type size description)
912   (cons name (list type size description)))
913
914 (define (enum->type name fields)
915   (make-type name 'enum 4 fields))
916
917 (define (struct->type name fields)
918   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
919
920 (define (decl->type o)
921   (pmatch o
922     ((fixed-type ,type) type)
923     ((struct-ref (ident ,name)) (list "struct" name))
924     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
925      (list "struct" name)) ;; FIXME
926     ((typename ,name) name)
927     (_
928      (stderr "SKIP: decl type=~s\n" o)
929      barf
930      o)))
931
932 (define (expr->global o)
933   (pmatch o
934     ((p-expr (string ,string)) (string->global string))
935     (_ #f)))
936
937 (define (initzer->global o)
938   (pmatch o
939     ((initzer ,initzer) (expr->global initzer))
940     (_ #f)))
941
942 (define (byte->hex o)
943   (string->number (string-drop o 2) 16))
944
945 (define (asm->hex o)
946   (let ((prefix ".byte "))
947     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
948         (let ((s (string-drop o (string-length prefix))))
949           (map byte->hex (string-split s #\space))))))
950
951 (define (case->jump-info info)
952   (define (jump n)
953     (wrap-as (i386:Xjump n)))
954   (define (jump-nz n)
955     (wrap-as (i386:Xjump-nz n)))
956   (define (statement->info info body-length)
957     (lambda (o)
958       (pmatch o
959         ((break) (append-text info (jump body-length)))
960         (_
961          ((ast->info info) o)))))
962   (lambda (o)
963     (pmatch o
964       ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
965        (lambda (body-length)
966
967          (define (test->text value clause-length)
968            (append (wrap-as (i386:accu-cmp-value value))
969                    (jump-nz clause-length)))
970          (let* ((value (assoc-ref (.constants info) constant))
971                 (test-info (append-text info (test->text value 0)))
972                 (text-length (length (.text test-info)))
973                 (clause-info (let loop ((elements elements) (info test-info))
974                                (if (null? elements) info
975                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
976                 (clause-text (list-tail (.text clause-info) text-length))
977                 (clause-length (length (text->list clause-text))))
978            (clone info #:text (append
979                                (.text info)
980                                (test->text value clause-length)
981                                clause-text)
982                   #:globals (.globals clause-info)))))
983
984       ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
985        (lambda (body-length)
986
987          (define (test->text value clause-length)
988            (append (wrap-as (i386:accu-cmp-value value))
989                    (jump-nz clause-length)))
990          (let* ((value (cstring->number value))
991                 (test-info (append-text info (test->text value 0)))
992                 (text-length (length (.text test-info)))
993                 (clause-info (let loop ((elements elements) (info test-info))
994                                (if (null? elements) info
995                                    (loop (cdr elements) ((statement->info info body-length) (car elements))))))
996                 (clause-text (list-tail (.text clause-info) text-length))
997                 (clause-length (length (text->list clause-text))))
998            (clone info #:text (append
999                                (.text info)
1000                                (test->text value clause-length)
1001                                clause-text)
1002                   #:globals (.globals clause-info)))))
1003
1004       ((case (neg (p-expr (fixed ,value))) ,statement)
1005        ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
1006
1007       ((default (compd-stmt (block-item-list . ,elements)))
1008        (lambda (body-length)
1009          (let ((text-length (length (.text info))))
1010            (let loop ((elements elements) (info info))
1011              (if (null? elements) info
1012                  (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
1013
1014       ((case (p-expr (ident ,constant)) ,statement)
1015        ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
1016
1017       ((case (p-expr (fixed ,value)) ,statement)
1018        ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
1019
1020       ((default ,statement)
1021        ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
1022
1023       (_ (stderr "no case match: ~a\n" o) barf)
1024       )))
1025
1026 (define (test->jump->info info)
1027   (define (jump type . test)
1028     (lambda (o)
1029       (let* ((text (.text info))
1030              (info (clone info #:text '()))
1031              (info ((ast->info info) o))
1032              (jump-text (lambda (body-length)
1033                           (wrap-as (type body-length)))))
1034         (lambda (body-length)
1035           (clone info #:text
1036                  (append text
1037                          (.text info)
1038                          (if (null? test) '() (car test))
1039                          (jump-text body-length)))))))
1040   (lambda (o)
1041     (pmatch o
1042       ;; unsigned
1043       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1044       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
1045       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1046       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1047
1048       ((le ,a ,b) ((jump i386:Xjump-g) o))
1049       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1050       ((ge ,a ,b) ((jump i386:Xjump-g) o))
1051       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1052
1053       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1054       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1055       ((not _) ((jump i386:Xjump-z) o))
1056       ((and ,a ,b)
1057        (let* ((text (.text info))
1058               (info (clone info #:text '()))
1059
1060               (a-jump ((test->jump->info info) a))
1061               (a-text (.text (a-jump 0)))
1062               (a-length (length (text->list a-text)))
1063
1064               (b-jump ((test->jump->info info) b))
1065               (b-text (.text (b-jump 0)))
1066               (b-length (length (text->list b-text))))
1067
1068          (lambda (body-length)
1069            (clone info #:text
1070                   (append text
1071                           (.text (a-jump (+ b-length body-length)))
1072                           (.text (b-jump body-length)))))))
1073       ((or ,a ,b)
1074        (let* ((text (.text info))
1075               (info (clone info #:text '()))
1076
1077               (a-jump ((test->jump->info info) a))
1078               (a-text (.text (a-jump 0)))
1079               (a-length (length (text->list a-text)))
1080
1081               (jump-text (wrap-as (i386:Xjump 0)))
1082               (jump-length (length (text->list jump-text)))
1083
1084               (b-jump ((test->jump->info info) b))
1085               (b-text (.text (b-jump 0)))
1086               (b-length (length (text->list b-text)))
1087
1088               (jump-text (wrap-as (i386:Xjump b-length))))
1089
1090          (lambda (body-length)
1091            (clone info #:text
1092                   (append text
1093                           (.text (a-jump jump-length))
1094                           jump-text
1095                           (.text (b-jump body-length)))))))
1096
1097       ((array-ref . _) ((jump i386:jump-byte-z
1098                               (wrap-as (i386:accu-zero?))) o))
1099
1100       ((de-ref _) ((jump i386:jump-byte-z
1101                          (wrap-as (i386:accu-zero?))) o))
1102
1103       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1104        ((jump i386:Xjump-z
1105               (append
1106                ((ident->accu info) name)
1107                (wrap-as (i386:accu-zero?)))) o))
1108
1109       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1110
1111 (define (cstring->number s)
1112   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1113         ((string-prefix? "0" s) (string->number s 8))
1114         (else (string->number s))))
1115
1116 (define (struct-field o)
1117   (pmatch o
1118     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1119                 (comp-declr-list (comp-declr (ident ,name))))
1120      (cons type name))
1121     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1122      (cons type name))
1123     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1124      (cons type name))
1125     ((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)))))))))
1126      (cons type name)) ;; FIXME function / int
1127     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1128      (cons type name)) ;; FIXME: ptr/char
1129     (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1130
1131 (define (ast->type o)
1132   (pmatch o
1133     ((fixed-type ,type)
1134      type)
1135     ((struct-ref (ident ,type))
1136      (list "struct" type))
1137     (_ (stderr "SKIP: type=~s\n" o)
1138        "int")))
1139
1140 (define i386:type-alist
1141   '(("char" . (builtin 1 #f))
1142     ("int" . (builtin 4 #f))))
1143
1144 (define (type->size info o)
1145   ;;(stderr  "types=~s\n" (.types info))
1146   ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
1147   (pmatch o
1148     ((decl-spec-list (type-spec (fixed-type ,type)))
1149      (type->size info type))
1150     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1151      (type->size info type))
1152     (_ (let ((type (assoc-ref (.types info) o)))
1153          (if type (cadr type)
1154              (begin
1155                (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1156                barf
1157                4))))))
1158
1159 (define (ident->decl info o)
1160   ;; (stderr "ident->decl o=~s\n" o)
1161   ;; (stderr "  types=~s\n" (.types info))
1162   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
1163   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
1164   (or (assoc-ref (.locals info) o)
1165       (assoc-ref (.globals info) o)
1166       (begin
1167         (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1168         (assoc-ref (.functions info) o))))
1169
1170 (define (ident->type info o)
1171   (and=> (ident->decl info o) car))
1172
1173 (define (ident->pointer info o)
1174   (let ((local (assoc-ref (.locals info) o)))
1175     (if local (local:pointer local)
1176         (or (and=> (ident->decl info o) global:pointer) 0))))
1177
1178 (define (type->description info o)
1179   ;; (stderr  "type->description =~s\n" o)  
1180   ;; (stderr  "types=~s\n" (.types info))
1181   ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
1182   ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
1183   (pmatch o
1184     ((decl-spec-list (type-spec (fixed-type ,type)))
1185      (type->description info type))
1186     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1187      (type->description info type))
1188     (_ (caddr (assoc-ref (.types info) o)))))
1189
1190 (define (local? o) ;; formals < 0, locals > 0
1191   (positive? (local:id o)))
1192
1193 (define (ast->info info)
1194   (lambda (o)
1195     (let ((globals (.globals info))
1196           (locals (.locals info))
1197           (constants (.constants info))
1198           (text (.text info)))
1199       (define (add-local locals name type pointer)
1200         (let* ((id (1+ (length (filter local? (map cdr locals)))))
1201                (locals (cons (make-local name type pointer id) locals)))
1202           locals))
1203
1204       ;; (stderr "\n ast->info=~s\n" o)
1205       ;; (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)))
1206       ;; (stderr "  text=~a\n" text)
1207       ;; (stderr "   info=~a\n" info)
1208       ;; (stderr "   globals=~a\n" globals)
1209       (pmatch o
1210         (((trans-unit . _) . _)
1211          ((ast-list->info info)  o))
1212         ((trans-unit . ,elements)
1213          ((ast-list->info info) elements))
1214         ((fctn-defn . _) ((function->info info) o))
1215         ((comment . _) info)
1216         ((cpp-stmt (define (name ,name) (repl ,value)))
1217          info)
1218
1219         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1220          info)
1221
1222         ;; FIXME: expr-stmt wrapper?
1223         (trans-unit info)
1224         ((expr-stmt) info)
1225
1226         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1227         
1228         ((if ,test ,body)
1229          (let* ((text-length (length text))
1230
1231                 (test-jump->info ((test->jump->info info) test))
1232                 (test+jump-info (test-jump->info 0))
1233                 (test-length (length (.text test+jump-info)))
1234
1235                 (body-info ((ast->info test+jump-info) body))
1236                 (text-body-info (.text body-info))
1237                 (body-text (list-tail text-body-info test-length))
1238                 (body-length (length (text->list body-text)))
1239
1240                 (text+test-text (.text (test-jump->info body-length)))
1241                 (test-text (list-tail text+test-text text-length)))
1242
1243            (clone info #:text
1244                   (append text
1245                           test-text
1246                           body-text)
1247                   #:globals (.globals body-info))))
1248
1249         ((if ,test ,then ,else)
1250          (let* ((text-length (length text))
1251
1252                 (test-jump->info ((test->jump->info info) test))
1253                 (test+jump-info (test-jump->info 0))
1254                 (test-length (length (.text test+jump-info)))
1255
1256                 (then-info ((ast->info test+jump-info) then))
1257                 (text-then-info (.text then-info))
1258                 (then-text (list-tail text-then-info test-length))
1259                 (then-jump-text (wrap-as (i386:Xjump 0)))
1260                 (then-jump-length (length (text->list then-jump-text)))
1261                 (then-length (+ (length (text->list then-text)) then-jump-length))
1262
1263                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1264                 (else-info ((ast->info then+jump-info) else))
1265                 (text-else-info (.text else-info))
1266                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1267                 (else-length (length (text->list else-text)))
1268
1269                 (text+test-text (.text (test-jump->info then-length)))
1270                 (test-text (list-tail text+test-text text-length))
1271                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1272
1273            (clone info #:text
1274                   (append text
1275                           test-text
1276                           then-text
1277                           then-jump-text
1278                           else-text)
1279                   #:globals (append (.globals then-info)
1280                                     (list-tail (.globals else-info) (length globals))))))
1281
1282         ;; Hmm?
1283         ((expr-stmt (cond-expr ,test ,then ,else))
1284          (let* ((text-length (length text))
1285
1286                 (test-jump->info ((test->jump->info info) test))
1287                 (test+jump-info (test-jump->info 0))
1288                 (test-length (length (.text test+jump-info)))
1289
1290                 (then-info ((ast->info test+jump-info) then))
1291                 (text-then-info (.text then-info))
1292                 (then-text (list-tail text-then-info test-length))
1293                 (then-length (length (text->list then-text)))
1294
1295                 (jump-text (wrap-as (i386:Xjump 0)))
1296                 (jump-length (length (text->list jump-text)))
1297
1298                 (test+then+jump-info
1299                  (clone then-info
1300                         #:text (append (.text then-info) jump-text)))
1301
1302                 (else-info ((ast->info test+then+jump-info) else))
1303                 (text-else-info (.text else-info))
1304                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1305                 (else-length (length (text->list else-text)))
1306
1307                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1308                 (test-text (list-tail text+test-text text-length))
1309                 (jump-text (wrap-as (i386:Xjump else-length))))
1310
1311            (clone info #:text
1312                   (append text
1313                           test-text
1314                           then-text
1315                           jump-text
1316                           else-text)
1317                   #:globals (.globals else-info))))
1318
1319         ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1320          (let* ((expr ((expr->accu info) expr))
1321                 (empty (clone info #:text '()))
1322                 (case-infos (map (case->jump-info empty) cases))
1323                 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1324                 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1325                               (if (null? cases) info
1326                                   (let ((c-j ((case->jump-info info) (car cases))))
1327                                     (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1328            cases-info))
1329
1330         ((for ,init ,test ,step ,body)
1331          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1332
1333                 (info ((ast->info info) init))
1334
1335                 (init-text (.text info))
1336                 (init-locals (.locals info))
1337                 (info (clone info #:text '()))
1338
1339                 (body-info ((ast->info info) body))
1340                 (body-text (.text body-info))
1341                 (body-length (length (text->list body-text)))
1342
1343                 (step-info ((expr->accu info) step))
1344                 (step-text (.text step-info))
1345                 (step-length (length (text->list step-text)))
1346
1347                 (test-jump->info ((test->jump->info info) test))
1348                 (test+jump-info (test-jump->info 0))
1349                 (test-length (length (text->list (.text test+jump-info))))
1350
1351                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1352
1353                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1354                 (jump-length (length (text->list jump-text)))
1355
1356                 (test-text (.text (test-jump->info jump-length))))
1357
1358            (clone info #:text
1359                   (append text
1360                           init-text
1361                           skip-body-text
1362                           body-text
1363                           step-text
1364                           test-text
1365                           jump-text)
1366                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1367                   #:locals locals)))
1368
1369         ;; FIXME: support break statement (see switch/case)
1370         ((while ,test ,body)
1371          (let* ((skip-info (lambda (body-length)
1372                              (clone info #:text (append text
1373                                                         (wrap-as (i386:Xjump body-length))))))
1374                 (text (.text (skip-info 0)))
1375                 (text-length (length text))
1376
1377                 (body-info (lambda (body-length)
1378                              ((ast->info (skip-info body-length)) body)))
1379                 (body-text (list-tail (.text (body-info 0)) text-length))
1380                 (body-length (length (text->list body-text)))
1381
1382                 (body-info (body-info body-length))
1383
1384                 (empty (clone info #:text '()))
1385                 (test-jump->info ((test->jump->info empty) test))
1386                 (test+jump-info (test-jump->info 0))
1387                 (test-length (length (text->list (.text test+jump-info))))
1388
1389                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1390                 (jump-length (length (text->list jump-text)))
1391
1392                 (test-text (.text (test-jump->info jump-length))))
1393            (clone info #:text
1394                   (append
1395                    (.text body-info)
1396                    test-text
1397                    jump-text)
1398                   #:globals (.globals body-info))))
1399
1400         ((do-while ,body ,test)
1401          (let* ((text-length (length text))
1402
1403                 (body-info ((ast->info info) body))
1404                 (body-text (list-tail (.text body-info) text-length))
1405                 (body-length (length (text->list body-text)))
1406
1407                 (empty (clone info #:text '()))
1408                 (test-jump->info ((test->jump->info empty) test))
1409                 (test+jump-info (test-jump->info 0))
1410                 (test-length (length (text->list (.text test+jump-info))))
1411
1412                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1413                 (jump-length (length (text->list jump-text)))
1414
1415                 (test-text (.text (test-jump->info jump-length))))
1416            (clone info #:text
1417                   (append
1418                    (.text body-info)
1419                    test-text
1420                    jump-text)
1421                   #:globals (.globals body-info))))
1422
1423         ((labeled-stmt (ident ,label) ,statement)
1424          (let ((info (append-text info (list label))))
1425            ((ast->info info) statement)))
1426
1427         ((goto (ident ,label))
1428          (let* ((jump (lambda (n) (i386:XXjump n)))
1429                 (offset (+ (length (jump 0)) (length (text->list text)))))
1430            (append-text info (append 
1431                               (list (lambda (f g ta t d)
1432                                       (jump (- (label-offset (.function info) label f) offset))))))))
1433
1434         ((return ,expr)
1435          (let ((info ((expr->accu info) expr)))
1436            (append-text info (append  (wrap-as (i386:ret)))))) 
1437
1438         ;; DECL
1439
1440         ;; int i;
1441         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1442          (if (.function info)
1443              (clone info #:locals (add-local locals name type 0))
1444              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1445
1446         ;; int i = 0;
1447         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1448          (let ((value (cstring->number value)))
1449            (if (.function info)
1450                (let* ((locals (add-local locals name type 0))
1451                       (info (clone info #:locals locals)))
1452                  (append-text info ((value->ident info) name value)))
1453                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1454
1455         ;; char c = 'A';
1456         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1457          (if (not (.function info)) decl-barf0)
1458          (let* ((locals (add-local locals name type 0))
1459                 (info (clone info #:locals locals))
1460                 (value (char->integer (car (string->list value)))))
1461            (append-text info ((value->ident info) name value))))
1462
1463         ;; int i = -1;
1464         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1465          (let ((value (- (cstring->number value))))
1466            (if (.function info)
1467                (let* ((locals (add-local locals name type 0))
1468                       (info (clone info #:locals locals)))
1469                  (append-text info ((value->ident info) name value)))
1470                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1471
1472         ;; int i = argc;
1473         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1474          (if (not (.function info)) decl-barf2)
1475          (let* ((locals (add-local locals name type 0))
1476                 (info (clone info #:locals locals)))
1477            (append-text info (append ((ident->accu info) local)
1478                                      ((accu->ident info) name)))))
1479
1480         ;; char *p = "t.c";
1481         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1482          (when (not (.function info))
1483            (stderr "o=~s\n" o)
1484            decl-barf3)
1485          (let* ((locals (add-local locals name type 1))
1486                 (globals (append globals (list (string->global string))))
1487                 (info (clone info #:locals locals #:globals globals)))
1488            (append-text info (append
1489                               (list (lambda (f g ta t d)
1490                                       (append
1491                                        (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1492                               ((accu->ident info) name)))))
1493         
1494         ;; char *p = 0;
1495         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1496          (let ((value (cstring->number value)))
1497            (if (.function info)
1498                (let* ((locals (add-local locals name type 1))
1499                       (info (clone info #:locals locals)))
1500                  (append-text info (append (wrap-as (i386:value->accu value))
1501                                            ((accu->ident info) name))))
1502                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1503
1504         ;; char arena[20000];
1505         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1506          (let ((type (ast->type type)))
1507            (if (.function info)
1508                TODO:decl-array 
1509                (let* ((globals (.globals info))
1510                       (count (cstring->number count))
1511                       (size (type->size info type))
1512                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1513                       (globals (append globals (list array))))
1514                  (clone info #:globals globals)))))
1515
1516         ;;struct scm *g_cells = (struct scm*)arena;
1517         ((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)))))))
1518          ;;(stderr "0TYPE: ~s\n" type)
1519          (if (.function info)
1520              (let* ((locals (add-local locals name type 1))
1521                     (info (clone info #:locals locals)))
1522                (append-text info (append ((ident->accu info) name)
1523                                          ((accu->ident info) value)))) ;; FIXME: deref?
1524              (let* ((globals (append globals (list (ident->global name type 1 0))))
1525                     (info (clone info #:globals globals)))
1526                (append-text info (append ((ident->accu info) name)
1527                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1528
1529         ;; SCM tmp;
1530         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1531          ;;(stderr  "1TYPE: ~s\n" type)
1532          (if (.function info)
1533              (clone info #:locals (add-local locals name type 0))
1534              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1535
1536         ;; SCM g_stack = 0;
1537         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1538          ;;(stderr  "2TYPE: ~s\n" type)
1539          (let ((value (cstring->number value)))
1540            (if (.function info)
1541                (let* ((locals (add-local locals name type 0))
1542                       (info (clone info #:locals locals)))
1543                  (append-text info ((value->ident info) name value)))
1544                (let ((globals (append globals (list (ident->global name type 0 value)))))
1545                  (clone info #:globals globals)))))
1546
1547         ;; SCM g_stack = 0; // comment
1548         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1549          ((ast->info info) (list-head o (- (length o) 1))))
1550
1551         ;; SCM i = argc;
1552         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1553          ;;(stderr  "3TYPE: ~s\n" type)
1554          (if (.function info)
1555              (let* ((locals (add-local locals name type 0))
1556                     (info (clone info #:locals locals)))
1557                (append-text info (append ((ident->accu info) local)
1558                                          ((accu->ident info) name))))
1559              (let* ((globals (append globals (list (ident->global name type 0 0))))
1560                     (info (clone info #:globals globals)))
1561                (append-text info (append ((ident->accu info) local)
1562                                          ((accu->ident info) name))))))
1563
1564         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1565         ((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))))
1566          (let* ((locals (add-local locals name type 1))
1567                 (info (clone info #:locals locals))
1568                 (empty (clone info #:text '()))
1569                 (accu ((expr->accu empty) initzer)))
1570            (clone info
1571                   #:text
1572                   (append text
1573                           (.text accu)
1574                           ((accu->ident info) name)
1575                           (list (lambda (f g ta t d)
1576                                   (append (i386:value->base ta)
1577                                           (i386:accu+base)))))
1578                   #:locals locals)))
1579
1580         ;; char *p = (char*)g_cells;
1581         ((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)))))))
1582          ;;(stderr  "6TYPE: ~s\n" type)
1583          (if (.function info)
1584              (let* ((locals (add-local locals name type 1))
1585                     (info (clone info #:locals locals)))
1586                (append-text info (append ((ident->accu info) value)
1587                                          ((accu->ident info) name))))
1588              (let* ((globals (append globals (list (ident->global name type 1 0))))
1589                     (here (data-offset name globals))
1590                     (there (data-offset value globals)))
1591                (clone info
1592                       #:globals globals
1593                       #:init (append (.init info)
1594                                      (list (lambda (functions globals ta t d data)
1595                                              (append
1596                                               (list-head data here)
1597                                               ;;; FIXME: type
1598                                               ;;; char *x = arena;
1599                                               (int->bv32 (+ d (data-offset value globals)))
1600                                               ;;; char *y = x;
1601                                               ;;;(list-head (list-tail data there) 4)
1602                                               (list-tail data (+ here 4))))))))))
1603
1604         ;; char *p = g_cells;
1605         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1606          ;;(stderr  "7TYPE: ~s\n" type)
1607          (let ((type (decl->type type)))
1608            ;;(stderr "0DECL: ~s\n" type)
1609            (if (.function info)
1610                (let* ((locals (add-local locals name type  1))
1611                       (info (clone info #:locals locals)))
1612                  (append-text info (append ((ident->accu info) value)
1613                                            ((accu->ident info) name))))
1614                (let* ((globals (append globals (list (ident->global name type 1 0))))
1615                       (here (data-offset name globals)))
1616                  (clone info
1617                         #:globals globals
1618                         #:init (append (.init info)
1619                                        (list (lambda (functions globals ta t d data)
1620                                                (append
1621                                                 (list-head data here)
1622                                               ;;; FIXME: type
1623                                               ;;; char *x = arena;p
1624                                                 (int->bv32 (+ d (data-offset value globals)))
1625                                                 (list-tail data (+ here 4)))))))))))
1626
1627         ;; enum 
1628         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1629          (let ((type (enum->type name fields))
1630                (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1631            (clone info
1632                   #:types (append (.types info) (list type))
1633                   #:constants (append constants (.constants info)))))
1634
1635         ;; struct
1636         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1637          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1638            ;;(stderr "type: ~a\n" type)
1639            (clone info #:types (append (.types info) (list type)))))
1640
1641         ;; DECL
1642         ;;
1643         ;; struct f = {...};
1644         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1645          (let* ((type (decl->type type))
1646                 ;;(foo (stderr "1DECL: ~s\n" type))
1647                 (fields (type->description info type))
1648                 (size (type->size info type))
1649                 (field-size 4))  ;; FIXME:4, not fixed
1650            ;;(stderr  "7TYPE: ~s\n" type)
1651            (if (.function info)
1652                (let* ((globals (append globals (filter-map initzer->global initzers)))
1653                       (locals (let loop ((fields (cdr fields)) (locals locals))
1654                                 (if (null? fields) locals
1655                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1656                       (locals (add-local locals name type -1))
1657                       (info (clone info #:locals locals #:globals globals))
1658                       (empty (clone info #:text '())))
1659                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1660                    (if (null? fields) info
1661                        (let ((offset (* field-size (car fields)))
1662                              (initzer (car initzers)))
1663                          (loop (cdr fields) (cdr initzers)
1664                                (clone info #:text
1665                                       (append
1666                                        (.text info)
1667                                        ((ident->accu info) name)
1668                                        (wrap-as (append (i386:accu->base)))
1669                                        (.text ((expr->accu empty) initzer))
1670                                        (wrap-as (i386:accu->base-address+n offset)))))))))
1671                (let* ((globals (append globals (filter-map initzer->global initzers)))
1672                       (global (make-global name type -1 (string->list (make-string size #\nul))))
1673                       (globals (append globals (list global)))
1674                       (here (data-offset name globals))
1675                       (info (clone info #:globals globals))
1676                       (field-size 4))
1677                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1678                    (if (null? fields) info
1679                        (let ((offset (* field-size (car fields)))
1680                              (initzer (car initzers)))
1681                          (loop (cdr fields) (cdr initzers)
1682                                (clone info #:init
1683                                       (append
1684                                        (.init info)
1685                                        (list (lambda (functions globals ta t d data)
1686                                                (append
1687                                                 (list-head data (+ here offset))
1688                                                 (initzer->data info functions globals ta t d (car initzers))
1689                                                 (list-tail data (+ here offset field-size)))))))))))))))
1690
1691
1692         ;;char cc = g_cells[c].cdr;  ==> generic?
1693         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1694          (let ((type (decl->type type)))
1695            (if (.function info)
1696                (let* ((locals (add-local locals name type 0))
1697                       (info (clone info #:locals locals)))
1698                  (clone info #:text
1699                         (append (.text ((expr->accu info) initzer))
1700                                 ((accu->ident info) name))))
1701                (let* ((globals (append globals (list (ident->global name type 1 0))))
1702                       (here (data-offset name globals)))
1703                  (clone info
1704                         #:globals globals
1705                         #:init (append (.init info)
1706                                        (list (lambda (functions globals ta t d data)
1707                                                (append
1708                                                 (list-head data here)
1709                                                 (initzer->data info functions globals ta t d initzer)
1710                                                 (list-tail data (+ here 4)))))))))))
1711
1712
1713         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1714          info)
1715
1716         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1717          info)
1718
1719         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1720          (let ((types (.types info)))
1721            (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1722
1723         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
1724          (format (current-error-port) "SKIP: typedef=~s\n" o)
1725          info)
1726
1727         ((decl (@ ,at))
1728          (format (current-error-port) "SKIP: at=~s\n" o)
1729          info)
1730
1731         ((decl . _)
1732          (format (current-error-port) "SKIP: decl statement=~s\n" o)
1733          barf
1734          info)
1735
1736         ;; ...
1737         ((gt . _) ((expr->accu info) o))
1738         ((ge . _) ((expr->accu info) o))
1739         ((ne . _) ((expr->accu info) o))
1740         ((eq . _) ((expr->accu info) o))
1741         ((le . _) ((expr->accu info) o))
1742         ((lt . _) ((expr->accu info) o))
1743         ((lshift . _) ((expr->accu info) o))
1744         ((rshift . _) ((expr->accu info) o))
1745
1746         ;; EXPR
1747         ((expr-stmt ,expression)
1748          (let ((info ((expr->accu info) expression)))
1749            (append-text info (wrap-as (i386:accu-zero?)))))
1750
1751         ;; FIXME: why do we get (post-inc ...) here
1752         ;; (array-ref
1753         (_ (let ((info ((expr->accu info) o)))
1754              (append-text info (wrap-as (i386:accu-zero?)))))))))
1755
1756 (define (initzer->data info functions globals ta t d o)
1757   (pmatch o
1758     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
1759     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
1760     ((initzer (ref-to (p-expr (ident ,name))))
1761      ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
1762      (int->bv32 (+ ta (function-offset name functions))))
1763     ((initzer (p-expr (ident ,name)))
1764      (let ((value (assoc-ref (.constants info) name)))
1765        (int->bv32 value)))
1766     ((initzer (p-expr (string ,string)))
1767      (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
1768     (_ (stderr "initzer->data:SKIP: ~s\n" o)
1769        barf
1770        (int->bv32 0))))
1771
1772 (define (info->exe info)
1773   (display "dumping elf\n" (current-error-port))
1774   (for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
1775
1776 (define (.formals o)
1777   (pmatch o
1778     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
1779     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
1780     (_ (format (current-error-port) ".formals: no match: ~a\n" o)
1781        barf)))
1782
1783 (define (formal->text n)
1784   (lambda (o i)
1785     ;;(i386:formal i n)
1786     '()
1787     ))
1788
1789 (define (formals->text o)
1790   (pmatch o
1791     ((param-list . ,formals)
1792      (let ((n (length formals)))
1793        (wrap-as (append (i386:function-preamble)
1794                         (append-map (formal->text n) formals (iota n))
1795                         (i386:function-locals)))))
1796     (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
1797        barf)))
1798
1799 (define (formal:ptr o)
1800   (pmatch o
1801     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1802      1)
1803     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
1804      0)
1805     (_
1806      (stderr "formal:ptr[~a] => 0\n" o)
1807      0)))
1808
1809 (define (formals->locals o)
1810   (pmatch o
1811     ((param-list . ,formals)
1812      (let ((n (length formals)))
1813        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
1814     (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
1815        barf)))
1816
1817 (define (function->info info)
1818   (lambda (o)
1819     ;;(stderr "function->info o=~s\n" o)
1820     ;;(stderr "formals=~s\n" (.formals o))
1821     (let* ((name (.name o))
1822            (formals (.formals o))
1823            (text (formals->text formals))
1824            (locals (formals->locals formals)))
1825       (format (current-error-port) "compiling ~s\n" name)
1826       ;;(stderr "locals=~s\n" locals)
1827       (let loop ((statements (.statements o))
1828                  (info (clone info #:locals locals #:function (.name o) #:text text)))
1829         (if (null? statements) (clone info
1830                                       #:function #f
1831                                       #:functions (append (.functions info) (list (cons name (.text info)))))
1832             (let* ((statement (car statements)))
1833               (loop (cdr statements)
1834                     ((ast->info info) (car statements)))))))))
1835
1836 (define (ast-list->info info)
1837   (lambda (elements)
1838     (let loop ((elements elements) (info info))
1839       (if (null? elements) info
1840           (loop (cdr elements) ((ast->info info) (car elements)))))))
1841
1842 (define (compile)
1843   (stderr "COMPILE\n")
1844   (let* ((ast (mescc))
1845          (info (make <info>
1846                  #:functions i386:libc
1847                  #:types i386:type-alist))
1848          (ast (append libc ast))
1849          (info ((ast->info info) ast))
1850          (info ((ast->info info) _start)))
1851     (info->exe info)))