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