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