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