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