mescc: Add missing builtins.
[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         ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
594          (let* ((type (list "struct" name))
595                 (fields (or (type->description info type) '()))
596                 (size (type->size info type)))
597            (append-text info (wrap-as (i386:value->accu size)))))
598
599         ;; c+p expr->arg
600         ;; g_cells[<expr>]
601         ((array-ref ,index (p-expr (ident ,array)))
602          (let* ((type (ident->type info array))
603                 (ptr (ident->pointer info array))
604                 (size (if (< ptr 2) (type->size info type)
605                           4))
606                 (info ((expr->accu* info) o)))
607            (append-text info (wrap-as (append (case size
608                                                 ((1) (i386:byte-mem->accu))
609                                                 ((4) (i386:mem->accu))
610                                                 (else '())))))))
611
612         ;; f.field
613         ((d-sel (ident ,field) (p-expr (ident ,array)))
614          (let* ((type (ident->type info array))
615                 (fields (type->description info type))
616                 (field-size 4) ;; FIXME:4, not fixed
617                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
618                 (text (.text info)))
619            (append-text info (append ((ident->accu info) array)
620                                      (wrap-as (i386:mem+n->accu offset))))))
621
622         ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
623          (let* ((type (ident->type info array))
624                 (fields (or (type->description info type) '()))
625                 (field-size 4) ;; FIXME:4, not fixed
626                 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
627                           (begin
628                             (stderr "no field:~a\n" field)
629                             '())))
630                 (offset (* field-size (1- (length rest))))
631                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
632            (append-text info (wrap-as (i386:mem+n->accu offset)))))
633
634         ((i-sel (ident ,field) (p-expr (ident ,array)))
635          (let* ((type (ident->type info array))
636                 (fields (type->description info type))
637                 (field-size 4) ;; FIXME:4, not fixed
638                 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
639                 (text (.text info)))
640            (append-text info (append ((ident-address->accu info) array)
641                                      (wrap-as (i386:mem->accu))
642                                      (wrap-as (i386:mem+n->accu offset))))))
643
644         ;;; FIXME: FROM INFO ...only zero?!
645         ((p-expr (fixed ,value))
646          (let ((value (cstring->number value)))
647            (append-text info (wrap-as (i386:value->accu value)))))
648
649         ((p-expr (char ,char))
650          (let ((char (char->integer (car (string->list char)))))
651            (append-text info (wrap-as (i386:value->accu char)))))
652
653         ((p-expr (ident ,name))
654          (append-text info ((ident->accu info) name)))
655
656         ((de-ref (p-expr (ident ,name)))
657          (let* ((type (ident->type info name))
658                 (ptr (ident->pointer info name))
659                 (size (if (= ptr 1) (type->size info type)
660                           4)))
661            (append-text info (append ((ident->accu info) name)
662                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
663                                                   (i386:mem->accu)))))))
664
665         ((de-ref (post-inc (p-expr (ident ,name))))
666          (let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
667                 (type (ident->type info name))
668                 (ptr (ident->pointer info name))
669                 (size (if (= ptr 1) (type->size info type)
670                           4)))
671            (append-text info ((ident-add info) name size))))
672
673         ((de-ref ,expr)
674          (let ((info ((expr->accu info) expr)))
675            (append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
676
677         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
678          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
679                                    (append-text info (wrap-as (asm->hex arg0))))
680              (let* ((text-length (length text))
681                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
682                                  (if (null? expressions) info
683                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
684                     (n (length expr-list)))
685                (if (and (not (assoc-ref locals name))
686                         (assoc name (.functions info)))
687                    (append-text args-info (list `(lambda (f g ta t d)
688                                                   (i386:call f g ta t d (+ t (function-offset ,name f)) ,n))))
689                    (let* ((empty (clone info #:text '()))
690                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
691                      (append-text args-info (append (.text accu)
692                                                     (list `(lambda (f g ta t d)
693                                                             (i386:call-accu f g ta t d ,n))))))))))
694
695         ((fctn-call ,function (expr-list . ,expr-list))
696          (let* ((text-length (length text))
697                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
698                              (if (null? expressions) info
699                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
700                 (n (length expr-list))
701                 (empty (clone info #:text '()))
702                 (accu ((expr->accu empty) function)))
703            (append-text args-info (append (.text accu)
704                                           (list `(lambda (f g ta t d)
705                                                   (i386:call-accu f g ta t d ,n)))))))
706
707         ((cond-expr . ,cond-expr)
708          ((ast->info info) `(expr-stmt ,o)))
709
710         ((post-inc (p-expr (ident ,name)))
711          (let* ((type (ident->type info name))
712                 (ptr (ident->pointer info name))
713                 (size (if (> ptr 1) 4 1)))
714            (append-text info (append ((ident->accu info) name)
715                                      ((ident-add info) name size)))))
716
717         ((post-dec (p-expr (ident ,name)))
718          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
719          (append-text info (append ((ident->accu info) name)
720                                    ((ident-add info) name -1))))
721
722         ((pre-inc (p-expr (ident ,name)))
723          (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) (error "undefined identifier: " name)))
724          (append-text info (append ((ident-add info) name 1)
725                                    ((ident->accu info) name))))
726
727         ((pre-dec (p-expr (ident ,name)))
728          (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) (error "undefined identifier: " name)))
729          (append-text info (append ((ident-add info) name -1)
730                                    ((ident->accu info) name))))
731
732         ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
733         ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
734         ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
735         ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
736         ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
737         ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
738         ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
739         ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
740         ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
741         ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
742
743         ((not ,expr)
744          (let* ((test-info ((ast->info info) expr)))
745            (clone info #:text
746                   (append (.text test-info)
747                           (wrap-as (i386:accu-not)))
748                   #:globals (.globals test-info))))
749
750         ((neg (p-expr (fixed ,value)))
751          (append-text info (value->accu (- (cstring->number value)))))
752
753         ((neg (p-expr (ident ,name)))
754          (append-text info (append ((ident->base info) name)
755                                    (wrap-as (i386:value->accu 0))
756                                    (wrap-as (i386:sub-base)))))
757
758         ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
759         ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
760         ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
761
762         ;; FIXME: set accu *and* flags
763         ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
764                                                     (i386:sub-base)
765                                                     (i386:nz->accu)
766                                                     (i386:accu<->stack)
767                                                     (i386:sub-base)
768                                                     (i386:xor-zf)
769                                                     (i386:pop-accu))))
770
771         ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
772         ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
773         ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
774
775         ((or ,a ,b)
776          (let* ((empty (clone info #:text '()))
777                 (b-length (length (append (i386:Xjump-nz 0)
778                                           (i386:accu-test))))
779                 (info ((expr->accu info) a))
780                 (info (append-text info (wrap-as (i386:accu-test))))
781                 (info (append-text info (wrap-as (append (i386:Xjump-nz (- b-length 1))
782                                                          (i386:accu-test)))))
783                 (info ((expr->accu info) b))
784                 (info (append-text info (wrap-as (i386:accu-test)))))
785            info))
786
787         ((and ,a ,b)
788          (let* ((empty (clone info #:text '()))
789                 (b-length (length (append (i386:Xjump-z 0)
790                                           (i386:accu-test))))
791                 (info ((expr->accu info) a))
792                 (info (append-text info (wrap-as (i386:accu-test))))
793                 (info (append-text info (wrap-as (append (i386:Xjump-z (- b-length 1))
794                                                          (i386:accu-test)))))
795                 (info ((expr->accu info) b))
796                 (info (append-text info (wrap-as (i386:accu-test)))))
797            info))
798
799         ((cast ,cast ,o)
800          ((expr->accu info) o))
801
802         ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
803          (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
804            (append-text info ((ident-add info) name 1)))) ;; FIXME: size
805
806         ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
807          (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
808            (append-text info ((ident-add info) name -1)))) ;; FIXME: size
809
810         ((assn-expr ,a (op ,op) ,b)
811          (let* ((info ((expr->accu info) b))
812                 (info (if (equal? op "=") info
813                           (let* ((info (append-text info (wrap-as (i386:push-accu))))
814                                  (info ((expr->accu info) a))
815                                  (info (append-text info (wrap-as (i386:pop-base)))))
816                             (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
817                                                     ((equal? op "-=") (wrap-as (i386:accu-base)))
818                                                     ((equal? op "*=") (wrap-as (i386:accu*base)))
819                                                     ((equal? op "/=") (wrap-as (i386:accu/base)))
820                                                     ((equal? op "%=") (wrap-as (i386:accu%base)))
821                                                     ((equal? op "|=") (wrap-as (i386:accu-or-base)))
822                                                     (else (error "mescc: op ~a not supported: ~a\n" op o))))))))
823            (pmatch a
824              ((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
825              ((d-sel (ident ,field) ,p-expr)
826               (let* ((type (p-expr->type info p-expr))
827                      (fields (type->description info type))
828                      (size (type->size info type))
829                      (field-size 4) ;; FIXME:4, not fixed
830                      (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))                
831                      (info (append-text info (wrap-as (i386:push-accu))))
832                      (info ((expr->accu* info) a))
833                      (info (append-text info (wrap-as (i386:pop-base)))))
834                 (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
835              ;; FIXME: c&p above
836              ((de-ref (p-expr (ident ,array)))
837               (let* ((type (ident->type info array))
838                      (ptr (ident->pointer info array))
839                      (size (if (> ptr 1) 4 1)))
840                 (append-text info (append (wrap-as (i386:accu->base))
841                                           ((base->ident-address info) array)
842                                           (i386:base->accu)))))
843              ((array-ref ,index (p-expr (ident ,array)))
844               (let* ((type (ident->type info array))
845                      (size (type->size info type))
846                      (info (append-text info (wrap-as (append (i386:push-accu)))))
847                      (info ((expr->accu* info) a))
848                      (info (append-text info (wrap-as (append (i386:pop-base))))))
849                 (append-text info
850                              (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
851                                          (if (<= size 4) (wrap-as (i386:base->accu-address))
852                                           (append
853                                            (wrap-as (i386:base-address->accu-address))
854                                            (wrap-as (append (i386:accu+n 4)
855                                                             (i386:base+n 4)
856                                                             (i386:base-address->accu-address)))
857                                            (if (<= size 8) '()
858                                                (wrap-as (append (i386:accu+n 4)
859                                                                 (i386:base+n 4)
860                                                                 (i386:base-address->accu-address)))))))))))
861              (_ (error "expr->accu: unsupported assign: " a)))))
862
863         (_ (error "expr->accu: unsupported: " o))))))
864
865 (define (expr->base info)
866   (lambda (o)
867     (let* ((info (append-text info (wrap-as (i386:push-accu))))
868            (info ((expr->accu info) o))
869            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
870       info)))
871
872 (define (binop->accu info)
873   (lambda (a b c)
874     (let* ((info ((expr->accu info) a))
875            (info ((expr->base info) b)))
876       (append-text info (wrap-as c)))))
877
878 (define (append-text info text)
879   (clone info #:text (append (.text info) text)))
880
881 (define (wrap-as o)
882   (list `(lambda (f g ta t d) ,(cons 'list o))))
883
884 (define (expr->accu* info)
885   (lambda (o)
886     (pmatch o
887       ;; g_cells[<expr>]
888       ((array-ref ,index (p-expr (ident ,array)))
889        (let* ((info ((expr->accu info) index))
890               (type (ident->type info array))
891               (ptr (ident->pointer info array))
892               (size (if (< ptr 2) (type->size info type)
893                         4)))
894          (append-text info (append (wrap-as (append (i386:accu->base)
895                                                     (if (eq? size 1) '()
896                                                         (append
897                                                          (if (<= size 4) '()
898                                                              (i386:accu+accu))
899                                                          (if (<= size 8) '()
900                                                              (i386:accu+base))
901                                                          (i386:accu-shl 2)))))
902                                    ((ident->base info) array)
903                                    (wrap-as (i386:accu+base))))))
904
905       ;; g_cells[<expr>].type
906       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
907        (let* ((type (ident->type info array))
908               (fields (or (type->description info type) '()))
909               (field-size 4) ;; FIXME:4, not fixed
910               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
911               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
912          (append-text info (wrap-as (append (i386:accu+value offset))))))
913
914       ((d-sel (ident ,field) (p-expr (ident ,name)))
915        (let* ((type (ident->type info name))
916               (fields (or (type->description info type) '()))
917               (field-size 4) ;; FIXME
918               (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
919               (text (.text info)))
920          (append-text info (append ((ident->accu info) name)
921                                    (wrap-as (i386:accu+value offset))))))
922
923       (_ (error "expr->accu*: unsupported: " o)))))
924
925 (define (ident->constant name value)
926   (cons name value))
927
928 (define (make-type name type size description)
929   (cons name (list type size description)))
930
931 (define (enum->type name fields)
932   (make-type name 'enum 4 fields))
933
934 (define (struct->type name fields)
935   (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
936
937 (define (decl->type o)
938   (pmatch o
939     ((fixed-type ,type) type)
940     ((struct-ref (ident ,name)) (list "struct" name))
941     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm"
942      (list "struct" name)) ;; FIXME
943     ((typename ,name) name)
944     (,name name)
945     (_ (error "decl->type: unsupported: " o))))
946
947 (define (expr->global o)
948   (pmatch o
949     ((p-expr (string ,string)) (string->global string))
950     ((p-expr (fixed ,value)) (int->global (cstring->number value)))
951     (_ #f)))
952
953 (define (initzer->global o)
954   (pmatch o
955     ((initzer ,initzer) (expr->global initzer))
956     (_ #f)))
957
958 (define (byte->hex o)
959   (string->number (string-drop o 2) 16))
960
961 (define (asm->hex o)
962   (let ((prefix ".byte "))
963     (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
964         (let ((s (string-drop o (string-length prefix))))
965           (map byte->hex (string-split s #\space))))))
966
967 (define (clause->jump-info info)
968   (define (jump n)
969     (wrap-as (i386:Xjump n)))
970   (define (jump-nz n)
971     (wrap-as (i386:Xjump-nz n)))
972   (define (jump-z n)
973     (wrap-as (i386:Xjump-z n)))
974   (define (statement->info info body-length)
975     (lambda (o)
976       (pmatch o
977         ((break) (append-text info (jump body-length)))
978         (_ ((ast->info info) o)))))
979   (define (test->text test)
980     (let ((value (pmatch test
981                    (0 0)
982                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
983                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
984                    ((p-expr (fixed ,value)) (cstring->number value))
985                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
986                    (_ (error "case test: unsupported: " test)))))
987       (lambda (n)
988         (append (wrap-as (i386:accu-cmp-value value))
989                 (jump-z (+ (length (object->list (jump 0)))
990                            (if (= n 0) 0
991                                (* n (length (object->list ((test->text 0) 0)))))))))))
992   (define (cases+jump cases clause-length)
993     (append-text info
994                  (append
995                   (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
996                   (if (null? cases) '()
997                       (jump clause-length)))))
998   (lambda (o)
999     (lambda (body-length)
1000       (let loop ((o o) (cases '()) (clause #f))
1001         (pmatch o
1002           ((case ,test ,statement)
1003            (loop statement (append cases (list (test->text test))) clause))
1004           ((default ,statement)
1005            (loop statement cases clause))
1006           ((compd-stmt (block-item-list))
1007            (loop '() cases clause))
1008           ((compd-stmt (block-item-list . ,elements))
1009            (let ((clause (or clause (cases+jump cases 0))))
1010              (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1011                    ((statement->info clause body-length) (car elements)))))
1012           (()
1013            (let* ((cases-length (length (.text (cases+jump cases 0))))
1014                   (clause-text (list-tail (.text clause) cases-length))
1015                   (clause-length (length (object->list clause-text))))
1016              (clone clause #:text
1017                     (append (.text (cases+jump cases clause-length))
1018                             clause-text))))
1019           (_
1020            (let ((clause (or clause (cases+jump cases 0))))
1021              (loop '() cases
1022                    ((statement->info clause body-length) o)))))))))
1023
1024 (define (test->jump->info info)
1025   (define (jump type . test)
1026     (lambda (o)
1027       (let* ((text (.text info))
1028              (info (clone info #:text '()))
1029              (info ((ast->info info) o))
1030              (jump-text (lambda (body-length)
1031                           (wrap-as (type body-length)))))
1032         (lambda (body-length)
1033           (clone info #:text
1034                  (append text
1035                          (.text info)
1036                          (if (null? test) '() (car test))
1037                          (jump-text body-length)))))))
1038   (lambda (o)
1039     (pmatch o
1040       ;; unsigned
1041       ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1042       ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o))  ; jae
1043       ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1044       ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1045
1046       ((le ,a ,b) ((jump i386:Xjump-g) o))
1047       ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1048       ((ge ,a ,b) ((jump i386:Xjump-g) o))
1049       ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1050
1051       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1052       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1053       ((not _) ((jump i386:Xjump-z) o))
1054       ((and ,a ,b)
1055        (let* ((globals (.globals info))
1056               (text (.text info))
1057               (info (clone info #:text '()))
1058
1059               (a-jump ((test->jump->info info) a))
1060               (a-text (.text (a-jump 0)))
1061               (a-length (length (object->list a-text)))
1062
1063               (b-jump ((test->jump->info info) b))
1064               (b-text (.text (b-jump 0)))
1065               (b-length (length (object->list b-text))))
1066
1067          (lambda (body-length)
1068            (let* ((info (append-text info text))
1069                   (a-info (a-jump (+ b-length body-length)))
1070                   (info (append-text info (.text a-info)))
1071                   (b-info (b-jump body-length))
1072                   (info (append-text info (.text b-info))))
1073             (clone info
1074                    #:globals (append globals
1075                                      (list-tail (.globals a-info) (length globals))
1076                                      (list-tail (.globals b-info) (length globals))))))))
1077
1078       ((or ,a ,b)
1079        (let* ((globals (.globals info))
1080               (text (.text info))
1081               (info (clone info #:text '()))
1082
1083               (a-jump ((test->jump->info info) a))
1084               (a-text (.text (a-jump 0)))
1085               (a-length (length (object->list a-text)))
1086
1087               (jump-text (wrap-as (i386:Xjump 0)))
1088               (jump-length (length (object->list jump-text)))
1089
1090               (b-jump ((test->jump->info info) b))
1091               (b-text (.text (b-jump 0)))
1092               (b-length (length (object->list b-text)))
1093
1094               (jump-text (wrap-as (i386:Xjump b-length))))
1095
1096          (lambda (body-length)
1097            (let* ((info (append-text info text))
1098                   (a-info (a-jump jump-length))
1099                   (info (append-text info (.text a-info)))
1100                   (info (append-text info jump-text))
1101                   (b-info (b-jump body-length))
1102                   (info (append-text info (.text b-info))))
1103             (clone info
1104                    #:globals (append globals
1105                                      (list-tail (.globals a-info) (length globals))
1106                                      (list-tail (.globals b-info) (length globals))))))))
1107
1108       ((array-ref . _) ((jump i386:jump-byte-z
1109                               (wrap-as (i386:accu-zero?))) o))
1110
1111       ((de-ref _) ((jump i386:jump-byte-z
1112                          (wrap-as (i386:accu-zero?))) o))
1113
1114       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1115        ((jump i386:Xjump-z
1116               (append
1117                ((ident->accu info) name)
1118                (wrap-as (i386:accu-zero?)))) o))
1119
1120       (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1121
1122 (define (cstring->number s)
1123   (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1124         ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1125         ((string-prefix? "0" s) (string->number s 8))
1126         (else (string->number s))))
1127
1128 (define (struct-field o)
1129   (pmatch o
1130     ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1131                 (comp-declr-list (comp-declr (ident ,name))))
1132      (cons type name))
1133     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1134      (cons type name))
1135     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1136      (cons type name))
1137     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1138      (cons type name)) ;; FIXME: **
1139     ((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-list)))))
1140      (cons type name)) ;; FIXME function / int
1141     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1142      (cons type name)) ;; FIXME: ptr/char
1143     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1144      (cons type name)) ;; FIXME: **
1145     ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1146      (cons '(void) name)) ;; FIXME: *
1147     ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)))))
1148      (cons '(void) name))
1149     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1150      (cons '(void) name))
1151     ;; FIXME: BufferedFile *include_stack[INCLUDE_STACK_SIZE];
1152     ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,size)))))))
1153      (cons type name)) ;; FIXME: decl, array size
1154     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,size))))))
1155      (cons type name))
1156     ;; struct InlineFunc **inline_fns;
1157     ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1158      (cons type name))
1159     ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1160      (cons type name))
1161     (_ (error "struct-field: unsupported: " o))))
1162
1163 (define (ast->type o)
1164   (pmatch o
1165     ((fixed-type ,type)
1166      type)
1167     ((struct-ref (ident ,type))
1168      (list "struct" type))
1169     (_ (stderr "SKIP: type=~s\n" o)
1170        "int")))
1171
1172 (define i386:type-alist
1173   '(("char" . (builtin 1 #f))
1174     ("short" . (builtin 2 #f))
1175     ("int" . (builtin 4 #f))
1176     ("long" . (builtin 4 #f))
1177     ("long long" . (builtin 8 #f))
1178     ;; FIXME sign
1179     ("unsigned char" . (builtin 1 #f))
1180     ("unsigned short" . (builtin 2 #f))
1181     ("unsigned" . (builtin 4 #f))
1182     ("unsigned int" . (builtin 4 #f))
1183     ("unsigned long" . (builtin 4 #f))
1184     ("unsigned long long" . (builtin 8 #f))))
1185
1186 (define (type->size info o)
1187   (pmatch o
1188     ((decl-spec-list (type-spec (fixed-type ,type)))
1189      (type->size info type))
1190     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1191      (type->size info type))
1192     ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
1193      (type->size info type))
1194     ((struct-ref (ident ,type))
1195      (type->size info `("struct" ,type)))
1196     (_ (let ((type (get-type (.types info) o)))
1197          (if type (cadr type)
1198              (error "type->size: unsupported: " o))))))
1199
1200 (define (ident->decl info o)
1201   (or (assoc-ref (.locals info) o)
1202       (assoc-ref (.globals info) o)
1203       (begin
1204         (stderr "NO IDENT: ~a\n" o)
1205         (assoc-ref (.functions info) o))))
1206
1207 (define (ident->type info o)
1208   (and=> (ident->decl info o) car))
1209
1210 (define (ident->pointer info o)
1211   (let ((local (assoc-ref (.locals info) o)))
1212     (if local (local:pointer local)
1213         (or (and=> (ident->decl info o) global:pointer) 0))))
1214
1215 (define (p-expr->type info o)
1216   (pmatch o
1217     ((p-expr (ident ,name)) (ident->type info name))
1218     ((array-ref ,index (p-expr (ident ,array)))
1219      (ident->type info array))
1220     (_ (error "p-expr->type: unsupported: " o))))
1221
1222 (define (get-type types o)
1223   (let ((t (assoc-ref types o)))
1224     (pmatch t
1225       ((typedef ,next) (get-type types next))
1226       (_ t))))
1227
1228 (define (type->description info o)
1229   (pmatch o
1230     ((decl-spec-list (type-spec (fixed-type ,type)))
1231      (type->description info type))
1232     ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1233      (type->description info type))
1234     ((struct-ref (ident ,type))
1235      (type->description info `("struct" ,type)))
1236     (_ (let ((type (get-type (.types info) o)))
1237          (if (not type) (stderr "TYPES=~s\n" (.types info)))
1238          (if type (caddr type)
1239              (error "type->description: unsupported:" o))))))
1240
1241 (define (local? o) ;; formals < 0, locals > 0
1242   (positive? (local:id o)))
1243
1244 (define (statements->clauses statements)
1245   (let loop ((statements statements) (clauses '()))
1246     (if (null? statements) clauses
1247         (let ((s (car statements)))
1248           (pmatch s
1249             ((case ,test (compd-stmt (block-item-list . _)))
1250              (loop (cdr statements) (append clauses (list s))))
1251             ((case ,test (break))
1252              (loop (cdr statements) (append clauses (list s))))
1253             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1254
1255             ((case ,test ,statement)
1256              (let loop2 ((statement statement) (heads `((case ,test))))
1257                (define (heads->case heads statement)
1258                  (if (null? heads) statement
1259                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1260                (pmatch statement
1261                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1262                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1263                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1264                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1265                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1266                           (let ((s (car statements)))
1267                             (pmatch s
1268                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1269                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1270                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1271                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1272             ((default (compd-stmt (block-item-list _)))
1273              (loop (cdr statements) (append clauses (list s))))
1274             ((default . ,statement)
1275              (let loop2 ((statements (cdr statements)) (c statement))
1276                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1277                    (let ((s (car statements)))
1278                      (pmatch s
1279                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1280                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1281                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1282                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1283
1284                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1285             (_ (error "statements->clauses: unsupported:" s)))))))
1286
1287 (define (ast->info info)
1288   (lambda (o)
1289     (let ((functions (.functions info))
1290           (globals (.globals info))
1291           (locals (.locals info))
1292           (constants (.constants info))
1293           (types (.types info))
1294           (text (.text info)))
1295       (define (add-local locals name type pointer)
1296         (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1297                        (1+ (local:id (cdar locals)))))
1298                (locals (cons (make-local name type pointer id) locals)))
1299           locals))
1300       (define (declare name)
1301         (if (member name functions) info
1302             (clone info #:functions (cons (cons name #f) functions))))
1303       (pmatch o
1304         (((trans-unit . _) . _)
1305          ((ast-list->info info)  o))
1306         ((trans-unit . ,elements)
1307          ((ast-list->info info) elements))
1308         ((fctn-defn . _) ((function->info info) o))
1309         ((cpp-stmt (define (name ,name) (repl ,value)))
1310          info)
1311
1312         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1313          info)
1314
1315         ((break)
1316          (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text)))))))
1317
1318         ;; FIXME: expr-stmt wrapper?
1319         (trans-unit info)
1320         ((expr-stmt) info)
1321
1322         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1323         
1324         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1325          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1326                                    (append-text info (wrap-as (asm->hex arg0))))
1327              (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1328                (append-text info (wrap-as (i386:accu-zero?))))))
1329
1330         ((if ,test ,body)
1331          (let* ((text-length (length text))
1332
1333                 (test-jump->info ((test->jump->info info) test))
1334                 (test+jump-info (test-jump->info 0))
1335                 (test-length (length (.text test+jump-info)))
1336
1337                 (body-info ((ast->info test+jump-info) body))
1338                 (text-body-info (.text body-info))
1339                 (body-text (list-tail text-body-info test-length))
1340                 (body-length (length (object->list body-text)))
1341
1342                 (text+test-text (.text (test-jump->info body-length)))
1343                 (test-text (list-tail text+test-text text-length)))
1344
1345            (clone info #:text
1346                   (append text
1347                           test-text
1348                           body-text)
1349                   #:globals (.globals body-info))))
1350
1351         ((if ,test ,then ,else)
1352          (let* ((text-length (length text))
1353
1354                 (test-jump->info ((test->jump->info info) test))
1355                 (test+jump-info (test-jump->info 0))
1356                 (test-length (length (.text test+jump-info)))
1357
1358                 (then-info ((ast->info test+jump-info) then))
1359                 (text-then-info (.text then-info))
1360                 (then-text (list-tail text-then-info test-length))
1361                 (then-jump-text (wrap-as (i386:Xjump 0)))
1362                 (then-jump-length (length (object->list then-jump-text)))
1363                 (then-length (+ (length (object->list then-text)) then-jump-length))
1364
1365                 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1366                 (else-info ((ast->info then+jump-info) else))
1367                 (text-else-info (.text else-info))
1368                 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1369                 (else-length (length (object->list else-text)))
1370
1371                 (text+test-text (.text (test-jump->info then-length)))
1372                 (test-text (list-tail text+test-text text-length))
1373                 (then-jump-text (wrap-as (i386:Xjump else-length))))
1374
1375            (clone info #:text
1376                   (append text
1377                           test-text
1378                           then-text
1379                           then-jump-text
1380                           else-text)
1381                   #:globals (append (.globals then-info)
1382                                     (list-tail (.globals else-info) (length globals))))))
1383
1384         ;; Hmm?
1385         ((expr-stmt (cond-expr ,test ,then ,else))
1386          (let* ((text-length (length text))
1387
1388                 (test-jump->info ((test->jump->info info) test))
1389                 (test+jump-info (test-jump->info 0))
1390                 (test-length (length (.text test+jump-info)))
1391
1392                 (then-info ((ast->info test+jump-info) then))
1393                 (text-then-info (.text then-info))
1394                 (then-text (list-tail text-then-info test-length))
1395                 (then-length (length (object->list then-text)))
1396
1397                 (jump-text (wrap-as (i386:Xjump 0)))
1398                 (jump-length (length (object->list jump-text)))
1399
1400                 (test+then+jump-info
1401                  (clone then-info
1402                         #:text (append (.text then-info) jump-text)))
1403
1404                 (else-info ((ast->info test+then+jump-info) else))
1405                 (text-else-info (.text else-info))
1406                 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1407                 (else-length (length (object->list else-text)))
1408
1409                 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1410                 (test-text (list-tail text+test-text text-length))
1411                 (jump-text (wrap-as (i386:Xjump else-length))))
1412
1413            (clone info #:text
1414                   (append text
1415                           test-text
1416                           then-text
1417                           jump-text
1418                           else-text)
1419                   #:globals (.globals else-info))))
1420
1421         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1422          (let* ((clauses (statements->clauses statements))
1423                 (expr ((expr->accu info) expr))
1424                 (empty (clone info #:text '()))
1425                 (clause-infos (map (clause->jump-info empty) clauses))
1426                 (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
1427                 (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
1428                               (if (null? clauses) info
1429                                   (let ((c-j ((clause->jump-info info) (car clauses))))
1430                                     (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1431            clauses-info))
1432
1433         ((for ,init ,test ,step ,body)
1434          (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1435
1436                 (info ((ast->info info) init))
1437
1438                 (init-text (.text info))
1439                 (init-locals (.locals info))
1440                 (info (clone info #:text '()))
1441
1442                 (body-info ((ast->info info) body))
1443                 (body-text (.text body-info))
1444                 (body-length (length (object->list body-text)))
1445
1446                 (step-info ((expr->accu info) step))
1447                 (step-text (.text step-info))
1448                 (step-length (length (object->list step-text)))
1449
1450                 (test-jump->info ((test->jump->info info) test))
1451                 (test+jump-info (test-jump->info 0))
1452                 (test-length (length (object->list (.text test+jump-info))))
1453
1454                 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1455
1456                 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1457                 (jump-length (length (object->list jump-text)))
1458
1459                 (test-text (.text (test-jump->info jump-length))))
1460
1461            (clone info #:text
1462                   (append text
1463                           init-text
1464                           skip-body-text
1465                           body-text
1466                           step-text
1467                           test-text
1468                           jump-text)
1469                   #:globals (append globals (list-tail (.globals body-info) (length globals)))
1470                   #:locals locals)))
1471
1472         ((while ,test ,body)
1473          (let* ((skip-info (lambda (body-length test-length)
1474                              (clone info
1475                                     #:text (append text (wrap-as (i386:Xjump body-length)))
1476                                     #:break (cons (+ (length (object->list text)) body-length test-length
1477                                                      (length (i386:Xjump 0)))
1478                                                   (.break info)))))
1479                 (text (.text (skip-info 0 0)))
1480                 (text-length (length text))
1481                 (body-info (lambda (body-length test-length)
1482                              ((ast->info (skip-info body-length test-length)) body)))
1483
1484                 (body-text (list-tail (.text (body-info 0 0)) text-length))
1485                 (body-length (length (object->list body-text)))
1486
1487                 (empty (clone info #:text '()))
1488                 (test-jump->info ((test->jump->info empty) test))
1489                 (test+jump-info (test-jump->info 0))
1490                 (test-length (length (object->list (.text test+jump-info))))
1491
1492                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1493                 (jump-length (length (object->list jump-text)))
1494
1495                 (test-text (.text (test-jump->info jump-length)))
1496
1497                 (body-info (body-info body-length (length (object->list test-text)))))
1498
1499            (clone info #:text
1500                   (append
1501                    (.text body-info)
1502                    test-text
1503                    jump-text)
1504                   #:globals (.globals body-info))))
1505
1506         ((do-while ,body ,test)
1507          (let* ((text-length (length text))
1508
1509                 (body-info ((ast->info info) body))
1510                 (body-text (list-tail (.text body-info) text-length))
1511                 (body-length (length (object->list body-text)))
1512
1513                 (empty (clone info #:text '()))
1514                 (test-jump->info ((test->jump->info empty) test))
1515                 (test+jump-info (test-jump->info 0))
1516                 (test-length (length (object->list (.text test+jump-info))))
1517
1518                 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1519                 (jump-length (length (object->list jump-text)))
1520
1521                 (test-text (.text (test-jump->info jump-length))))
1522            (clone info #:text
1523                   (append
1524                    (.text body-info)
1525                    test-text
1526                    jump-text)
1527                   #:globals (.globals body-info))))
1528
1529         ((labeled-stmt (ident ,label) ,statement)
1530          (let ((info (append-text info (list label))))
1531            ((ast->info info) statement)))
1532
1533         ((goto (ident ,label))
1534          (let* ((jump (lambda (n) (i386:XXjump n)))
1535                 (offset (+ (length (jump 0)) (length (object->list text)))))
1536            (append-text info (append 
1537                               (list `(lambda (f g ta t d)
1538                                       (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
1539
1540         ((return ,expr)
1541          (let ((info ((expr->accu info) expr)))
1542            (append-text info (append (wrap-as (i386:ret))))))
1543
1544         ;; DECL
1545
1546         ;; int i;
1547         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1548          (if (.function info)
1549              (clone info #:locals (add-local locals name type 0))
1550              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1551
1552         ;; enum e i;
1553         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1554          (let ((type "int")) ;; FIXME
1555            (if (.function info)
1556                (clone info #:locals (add-local locals name type 0))
1557                (clone info #:globals (append globals (list (ident->global name type 0 0)))))))
1558
1559         ;; int i = 0;
1560         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1561          (let ((value (cstring->number value)))
1562            (if (.function info)
1563                (let* ((locals (add-local locals name type 0))
1564                       (info (clone info #:locals locals)))
1565                  (append-text info ((value->ident info) name value)))
1566                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1567
1568         ;; char c = 'A';
1569         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1570          (if (not (.function info)) (error "ast->info: unsupported: " o))
1571          (let* ((locals (add-local locals name type 0))
1572                 (info (clone info #:locals locals))
1573                 (value (char->integer (car (string->list value)))))
1574            (append-text info ((value->ident info) name value))))
1575
1576         ;; int i = -1;
1577         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1578          (let ((value (- (cstring->number value))))
1579            (if (.function info)
1580                (let* ((locals (add-local locals name type 0))
1581                       (info (clone info #:locals locals)))
1582                  (append-text info ((value->ident info) name value)))
1583                (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1584
1585         ;; int i = argc;
1586         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1587          (if (not (.function info)) (error "ast->info: unsupported: " o))
1588          (let* ((locals (add-local locals name type 0))
1589                 (info (clone info #:locals locals)))
1590            (append-text info (append ((ident->accu info) local)
1591                                      ((accu->ident info) name)))))
1592
1593         ;; char *p = "foo";
1594         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1595          (if (.function info)
1596              (let* ((locals (add-local locals name type 1))
1597                     (globals (append globals (list (string->global string))))
1598                     (info (clone info #:locals locals #:globals globals)))
1599                (append-text info (append
1600                                   (list `(lambda (f g ta t d)
1601                                           (append
1602                                            (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
1603                                   ((accu->ident info) name))))
1604              (let* ((global (string->global string))
1605                     (globals (append globals (list global)))
1606                     (size 4)
1607                     (global (make-global name type 1 (string->list (make-string size #\nul))))
1608                     (globals (append globals (list global)))
1609                     (info (clone info #:globals globals)))
1610                (clone info #:init
1611                       (append
1612                        (.init info)
1613                        (list
1614                         `(lambda (f g ta t d data)
1615                            (let (((here (data-offset ,name g))))
1616                              (append
1617                               (list-head data here)
1618                               (initzer->data f g ta t d '(initzer (p-expr (string ,string))))
1619                               (list-tail data (+ here ,size)))))))))))
1620         
1621         ;; char const *p;
1622         ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1623          (if (.function info)
1624              (let* ((locals (add-local locals name type 1))
1625                     (info (clone info #:locals locals)))
1626                (append-text info (append (wrap-as (i386:value->accu 0))
1627                                          ((accu->ident info) name))))
1628              (let ((globals (append globals (list (ident->global name type 1 0)))))
1629                (clone info #:globals globals))))
1630
1631         ;; char *p;
1632         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1633          (if (.function info)
1634              (let* ((locals (add-local locals name type 1))
1635                     (info (clone info #:locals locals)))
1636                (append-text info (append (wrap-as (i386:value->accu 0))
1637                                          ((accu->ident info) name))))
1638              (let ((globals (append globals (list (ident->global name type 1 0)))))
1639                (clone info #:globals globals))))
1640
1641         ;; char *p = 0;
1642         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1643          (let ((value (cstring->number value)))
1644            (if (.function info)
1645                (let* ((locals (add-local locals name type 1))
1646                       (info (clone info #:locals locals)))
1647                  (append-text info (append (wrap-as (i386:value->accu value))
1648                                            ((accu->ident info) name))))
1649                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1650
1651         ;; FILE *p;
1652         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1653          (if (.function info)
1654              (let* ((locals (add-local locals name type 1))
1655                     (info (clone info #:locals locals)))
1656                (append-text info (append (wrap-as (i386:value->accu 0))
1657                                          ((accu->ident info) name))))
1658              (let ((globals (append globals (list (ident->global name type 1 0)))))
1659                (clone info #:globals globals))))
1660
1661         ;; FILE *p = 0;
1662         ((decl (decl-spec-list (type-spec (typename ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1663          (let ((value (cstring->number value)))
1664            (if (.function info)
1665                (let* ((locals (add-local locals name type 1))
1666                       (info (clone info #:locals locals)))
1667                  (append-text info (append (wrap-as (i386:value->accu value))
1668                                            ((accu->ident info) name))))
1669                (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1670
1671         ;; char **p;
1672         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1673          (if (.function info)
1674              (let* ((locals (add-local locals name type 2))
1675                     (info (clone info #:locals locals)))
1676                (append-text info (append (wrap-as (i386:value->accu 0))
1677                                          ((accu->ident info) name))))
1678              (let ((globals (append globals (list (ident->global name type 2 0)))))
1679                (clone info #:globals globals))))
1680
1681         ;; char **p = 0;
1682         ;;((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)))))))
1683
1684         ;; char **p = g_environment;
1685         ((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
1686          (if (.function info)
1687              (let* ((locals (add-local locals name type 2))
1688                     (info (clone info #:locals locals)))
1689                (append-text info (append
1690                                   ((ident->accu info) b)
1691                                   ((accu->ident info) name))))
1692              (let* ((globals (append globals (list (ident->global name type 2 0))))
1693                     (value (assoc-ref constants b)))
1694                (clone info
1695                       #:globals globals
1696                       #:init (append (.init info)
1697                                      (list
1698                                       `(lambda (f g ta t d data)
1699                                          (let ((here (data-offset ,name g)))
1700                                            (append
1701                                             (list-head data here)
1702                                             (initzer->data f g ta t d '(p-expr (fixed ,value)))
1703                                             (list-tail data (+ here 4)))))))))))
1704
1705         ;; struct foo bar[2];
1706         ;; char arena[20000];
1707         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1708          (let ((type (ast->type type)))
1709            (if (.function info)
1710                (let* ((local (car (add-local locals name type -1)))
1711                       (count (string->number count))
1712                       (size (type->size info type))
1713                       (local (make-local name type -1 (+ (local:id local) (* count size))))
1714                       (locals (cons local locals))
1715                       (info (clone info #:locals locals)))
1716                  info)
1717                (let* ((globals (.globals info))
1718                       (count (cstring->number count))
1719                       (size (type->size info type))
1720                       (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1721                       (globals (append globals (list array))))
1722                  (clone info #:globals globals)))))
1723
1724         ;; char* a[10];
1725         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1726          (let ((type (ast->type type)))
1727            (if (.function info)
1728                (let* ((local (car (add-local locals name type -1)))
1729                       (count (string->number count))
1730                       (size (type->size info type))
1731                       (local (make-local name type 1 (+ (local:id local) (* count size))))
1732                       (locals (cons local locals))
1733                       (info (clone info #:locals locals)))
1734                  info)
1735                (let* ((globals (.globals info))
1736                       (count (cstring->number count))
1737                       (size (type->size info type))
1738                       (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1739                       (globals (append globals (list array))))
1740                  (clone info #:globals globals)))))
1741
1742         ;; struct foo bar;
1743         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1744          (if (.function info)
1745              (let* ((locals (add-local locals name `("struct" ,type) 1))
1746                     (info (clone info #:locals locals)))
1747                info)
1748              (let* ((size (type->size info (list "struct" type)))
1749                     (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1750                     (globals (append globals (list global)))
1751                     (info (clone info #:globals globals)))
1752                info)))
1753
1754         ;;struct scm *g_cells = (struct scm*)arena;
1755         ((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)))))))
1756          (if (.function info)
1757              (let* ((locals (add-local locals name `("struct" ,type) 1))
1758                     (info (clone info #:locals locals)))
1759                (append-text info (append ((ident->accu info) name)
1760                                          ((accu->ident info) value)))) ;; FIXME: deref?
1761              (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1762                     (info (clone info #:globals globals)))
1763                (append-text info (append ((ident->accu info) name)
1764                                          ((accu->ident info) value)))))) ;; FIXME: deref?
1765
1766
1767         ;; SCM tmp;
1768         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1769          (if (.function info)
1770              (clone info #:locals (add-local locals name type 0))
1771              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1772
1773         ;; SCM g_stack = 0;
1774         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1775          (let ((value (cstring->number value)))
1776            (if (.function info)
1777                (let* ((locals (add-local locals name type 0))
1778                       (info (clone info #:locals locals)))
1779                  (append-text info ((value->ident info) name value)))
1780                (let ((globals (append globals (list (ident->global name type 0 value)))))
1781                  (clone info #:globals globals)))))
1782
1783         ;; SCM i = argc;
1784         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1785          (if (.function info)
1786              (let* ((locals (add-local locals name type 0))
1787                     (info (clone info #:locals locals)))
1788                (append-text info (append ((ident->accu info) local)
1789                                          ((accu->ident info) name))))
1790              (let* ((globals (append globals (list (ident->global name type 0 0))))
1791                     (info (clone info #:globals globals)))
1792                (append-text info (append ((ident->accu info) local)
1793                                          ((accu->ident info) name))))))
1794
1795         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1796         ((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))))
1797          (let* ((locals (add-local locals name type 1))
1798                 (info (clone info #:locals locals))
1799                 (empty (clone info #:text '()))
1800                 (accu ((expr->accu empty) initzer)))
1801            (clone info
1802                   #:text
1803                   (append text
1804                           (.text accu)
1805                           ((accu->ident info) name)
1806                           (list `(lambda (f g ta t d)
1807                                   (append (i386:value->base ta)
1808                                           (i386:accu+base)))))
1809                   #:locals locals)))
1810
1811         ;; char *p = (char*)g_cells;
1812         ((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)))))))
1813          (if (.function info)
1814              (let* ((locals (add-local locals name type 1))
1815                     (info (clone info #:locals locals)))
1816                (append-text info (append ((ident->accu info) value)
1817                                          ((accu->ident info) name))))
1818              (let* ((globals (append globals (list (ident->global name type 1 0)))))
1819                (clone info
1820                       #:globals globals
1821                       #:init (append (.init info)
1822                                      (list
1823                                       `(lambda (f g ta t d data)
1824                                          (let ((here (data-offset ,name g))
1825                                                (there (data-offset ,value g)))
1826                                            (append
1827                                             (list-head data here)
1828                                             ;; FIXME: type
1829                                             ;; char *x = arena;
1830                                             (int->bv32 (+ d (data-offset ,value g)))
1831                                             ;; char *y = x;
1832                                             ;;(list-head (list-tail data there) 4)
1833                                             (list-tail data (+ here 4)))))))))))
1834
1835         ;; char *p = g_cells;
1836         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1837          (let ((type (decl->type type)))
1838            (if (.function info)
1839                (let* ((locals (add-local locals name type  1))
1840                       (info (clone info #:locals locals)))
1841                  (append-text info (append ((ident->accu info) value)
1842                                            ((accu->ident info) name))))
1843                (let* ((globals (append globals (list (ident->global name type 1 0)))))
1844                  (clone info
1845                         #:globals globals
1846                         #:init (append (.init info)
1847                                        (list `(lambda (f g ta t d data)
1848                                                 (let ((here (data-offset ,name g)))
1849                                                   (append
1850                                                    (list-head data here)
1851                                                    ;; FIXME: type
1852                                                    ;; char *x = arena;p
1853                                                    (int->bv32 (+ d (data-offset ,value g)))
1854                                                    (list-tail data (+ here 4))))))))))))
1855
1856         ;; enum foo { };
1857         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1858          (let ((type (enum->type name fields))
1859                (constants (enum-def-list->constants constants fields)))
1860            (clone info
1861                   #:types (append types (list type))
1862                   #:constants (append constants (.constants info)))))
1863
1864         ;; enum {};
1865         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
1866          (let ((constants (enum-def-list->constants constants fields)))
1867            (clone info
1868                   #:constants (append constants (.constants info)))))
1869
1870         ;; FIXME TCC/Nyacc madness here: extra parentheses around struct name?!?
1871         ;; struct (FOO) WTF?
1872         ((decl (decl-spec-list (type-spec (struct-def (ident (,name)) (field-list . ,fields)))))
1873          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1874            (clone info #:types (append types (list type)))))
1875
1876         ((decl (decl-spec-list (type-spec (struct-def (ident (,type)) (field-list . ,fields))))
1877                (init-declr-list (init-declr (ident ,name))))
1878          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1879            ((ast->info info)
1880             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1881
1882         ;; struct foo* bar = expr;
1883          ((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)))))))
1884          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1885                                      (info (clone info #:locals locals)))
1886                  (append-text info (append ((ident-address->accu info) value)
1887                                            ((accu->ident info) name))))
1888              (error "ast->info: unsupported global:" o)))
1889          ;; END FIXME -- dupe of the below
1890
1891
1892         ;; struct
1893         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1894          (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1895            (clone info #:types (cons type types))))
1896
1897         ;; struct foo {} bar;
1898         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1899                (init-declr-list (init-declr (ident ,name))))
1900          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1901            ((ast->info info)
1902             `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1903
1904         ;; struct foo* bar = expr;
1905          ((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)))))))
1906          (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1907                                      (info (clone info #:locals locals)))
1908                  (append-text info (append ((ident-address->accu info) value)
1909                                            ((accu->ident info) name))))
1910              (error "ast->info: unsupported global:" o)))
1911
1912         ;; char *p = &bla;
1913         ((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)))))))
1914          (let ((type (decl->type type)))
1915            (if (.function info)
1916                (let* ((locals (add-local locals name type 1))
1917                       (info (clone info #:locals locals)))
1918                  (append-text info (append ((ident-address->accu info) value)
1919                                            ((accu->ident info) name))))
1920                (error "TODO" o))))
1921
1922         ;; char **p = &bla;
1923         ((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)))))))
1924          (let ((type (decl->type type)))
1925            (if (.function info)
1926                (let* ((locals (add-local locals name type 2))
1927                       (info (clone info #:locals locals)))
1928                  (append-text info (append ((ident-address->accu info) value)
1929                                            ((accu->ident info) name))))
1930                (error "TODO" o))))
1931
1932         ;; char *p = bla[0];
1933         ((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)))))))
1934          (if (.function info)
1935              (let* ((locals (add-local locals name type 1))
1936                     (info (clone info #:locals locals))
1937                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1938                (append-text info ((accu->ident info) name)))
1939              (error "TODO" o)))
1940
1941         ;; char *foo = &bar[0];
1942         ((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))))))))
1943          (if (.function info)
1944              (let* ((locals (add-local locals name type 1))
1945                     (info (clone info #:locals locals))
1946                     (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1947                (append-text info ((accu->ident info) name)))
1948              (error "TODO" o)))
1949
1950         ;; char *p = *bla;
1951         ((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)))))))
1952          (if (.function info)
1953              (let* ((locals (add-local locals name type 1))
1954                     (info (clone info #:locals locals))
1955                     (local (assoc-ref (.locals info) name)))
1956                (append-text info (append ((ident->accu info) value)
1957                                          (wrap-as (i386:mem->accu))
1958                                          ((accu->ident info) name))))
1959              (error "TODO" o)))
1960
1961         ;; DECL
1962         ;; char *bla[] = {"a", "b"};
1963         ((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)))))
1964          (let* ((type (decl->type type))
1965                 (entries (map initzer->global initzers))
1966                 (entry-size 4)
1967                 (size (* (length entries) entry-size))
1968                 (initzers (map (initzer->non-const info) initzers)))
1969            (if (.function info)
1970                (error "TODO: <type> x[] = {};" o)
1971                (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1972                       (globals (append globals entries (list global)))
1973                       (info (clone info #:globals globals)))
1974                  (clone info #:init
1975                         (append
1976                          (.init info)
1977                          (list
1978                           `(lambda (f g ta t d data)
1979                              (let ((here (data-offset ,name g)))
1980                                (append
1981                                 (list-head data here)
1982                                 (append-map
1983                                  (lambda (i)
1984                                    (initzer->data f g ta t d i))
1985                                  ',initzers)
1986                                 (list-tail data (+ here ,size))))))))))))
1987
1988         ;;
1989         ;; struct f = {...};
1990         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1991          (let* ((type (decl->type type))
1992                 (fields (type->description info type))
1993                 (size (type->size info type))
1994                 (field-size 4)  ;; FIXME:4, not fixed
1995                 (initzers (map (initzer->non-const info) initzers)))
1996            (if (.function info)
1997                (let* ((globals (append globals (filter-map initzer->global initzers)))
1998                       (locals (let loop ((fields (cdr fields)) (locals locals))
1999                                 (if (null? fields) locals
2000                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2001                       (locals (add-local locals name type -1))
2002                       (info (clone info #:locals locals #:globals globals))
2003                       (empty (clone info #:text '())))
2004                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2005                    (if (null? fields) info
2006                        (let ((offset (* field-size (car fields)))
2007                              (initzer (car initzers)))
2008                          (loop (cdr fields) (cdr initzers)
2009                                (clone info #:text
2010                                       (append
2011                                        (.text info)
2012                                        ((ident->accu info) name)
2013                                        (wrap-as (append (i386:accu->base)))
2014                                        (.text ((expr->accu empty) initzer))
2015                                        (wrap-as (i386:accu->base-address+n offset)))))))))
2016                (let* ((globals (append globals (filter-map initzer->global initzers)))
2017                       (global (make-global name type -1 (string->list (make-string size #\nul))))
2018                       (globals (append globals (list global)))
2019                       (info (clone info #:globals globals))
2020                       (field-size 4))
2021                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2022                    (if (null? fields) info
2023                        (let ((offset (* field-size (car fields)))
2024                              (initzer (car initzers)))
2025                          (loop (cdr fields) (cdr initzers)
2026                                (clone info #:init
2027                                       (append
2028                                        (.init info)
2029                                        (list
2030                                         `(lambda (f g ta t d data)
2031                                            (let ((here (data-offset ,name g)))
2032                                              (append
2033                                               (list-head data (+ here ,offset))
2034                                               (initzer->data f g ta t d ',(car initzers))
2035                                               (list-tail data (+ here ,offset ,field-size))))))))))))))))
2036
2037
2038         ;;char cc = g_cells[c].cdr;  ==> generic?
2039         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2040          (let ((type (decl->type type))
2041                (initzer ((initzer->non-const info) initzer)))
2042            (if (.function info)
2043                (let* ((locals (add-local locals name type 0))
2044                       (info (clone info #:locals locals)))
2045                  (clone info #:text
2046                         (append (.text ((expr->accu info) initzer))
2047                                 ((accu->ident info) name))))
2048                (let* ((globals (append globals (list (ident->global name type 1 0)))))
2049                  (clone info
2050                         #:globals globals
2051                         #:init (append (.init info)
2052                                        (list
2053                                         `(lambda (f g ta t d data)
2054                                            (let ((here (data-offset ,name g)))
2055                                              (append
2056                                               (list-head data here)
2057                                               (initzer->data f g ta t d ',initzer)
2058                                               (list-tail data (+ here 4))))))))))))
2059
2060
2061         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2062          (declare name))
2063
2064         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2065          (clone info #:types (cons (cons name (get-type types type)) types)))
2066
2067         ;; int foo ();
2068         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2069          (declare name))
2070
2071         ;; void foo ();
2072         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2073          (declare name))
2074
2075         ;; void foo (*);
2076         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
2077          (declare name))
2078
2079         ;; char const* itoa ();
2080         ((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))))))
2081          (declare name))
2082
2083         ;; char *strcpy ();
2084         ((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))))))
2085          (declare name))
2086
2087         ;; printf (char const* format, ...)
2088         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
2089          (declare name))
2090
2091         ;; <name> tcc_new
2092         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
2093          (declare name))
2094
2095         ;; extern type foo ()
2096         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2097          (declare name))
2098
2099         ;; struct TCCState;
2100         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
2101          info)
2102
2103         ;; extern type global;
2104         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
2105          info)
2106
2107         ;; ST_DATA struct TCCState *tcc_state;
2108         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2109          info)
2110
2111         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
2112         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
2113          info)
2114
2115         ;; ST_DATA const int *macro_ptr;
2116         ((decl (decl-spec-list (stor-spec (extern)) (type-qual ,qual) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2117          info)
2118
2119         ;; ST_DATA TokenSym **table_ident;
2120         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
2121          info)
2122
2123         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
2124         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
2125          info)
2126
2127         ;; ST_DATA void **sym_pools;
2128         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
2129          info)
2130
2131         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
2132         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
2133          info)
2134
2135         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
2136         ;; Yay, let's hear it for the T-for Tiny in TCC!?
2137         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))) (init-declr (ptr-declr (pointer) (ident ,name2)))))
2138          info)
2139
2140         ;; ST_DATA char *funcname;
2141         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2142          info)
2143
2144         ;; ST_DATA const int reg_classes[NB_REGS];
2145         ((decl (decl-spec-list (stor-spec (extern)) (type-qual ,qual) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,size))))))
2146          info)
2147
2148         ;; int i = 0, j = 0;
2149         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2150          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2151            (if (null? inits) info
2152                (loop (cdr inits)
2153                      ((ast->info info)
2154                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2155
2156         ;; char *foo[0], *bar;
2157         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,index)) . ,rest))
2158          (let loop ((inits `((init-declr (array-of (ident ,name) ,index)) ,@rest)) (info info))
2159            (if (null? inits) info
2160                (loop (cdr inits)
2161                      ((ast->info info)
2162                       `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2163
2164
2165         ;; const char *target; silly notation, const always operates to the LEFT (except when there's no left)
2166         ((decl (decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2167          ((ast->info info)
2168           `(decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))))
2169
2170         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name))))
2171          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2172
2173         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2174          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2175
2176         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2177          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
2178
2179         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
2180          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
2181
2182         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
2183          (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name)))))))
2184            (clone info #:types (cons (cons name (or (get-type types `("struct" ,name)) `(typedef ,name))) types))))
2185
2186         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2187          (format (current-error-port) "SKIP: typedef=~s\n" o)
2188          info)        
2189
2190         ((decl (@ ,at))
2191          (format (current-error-port) "SKIP: at=~s\n" o)
2192          info)
2193
2194         ((decl . _) (error "ast->info: unsupported: " o))
2195
2196         ;; ...
2197         ((gt . _) ((expr->accu info) o))
2198         ((ge . _) ((expr->accu info) o))
2199         ((ne . _) ((expr->accu info) o))
2200         ((eq . _) ((expr->accu info) o))
2201         ((le . _) ((expr->accu info) o))
2202         ((lt . _) ((expr->accu info) o))
2203         ((lshift . _) ((expr->accu info) o))
2204         ((rshift . _) ((expr->accu info) o))
2205
2206         ;; EXPR
2207         ((expr-stmt ,expression)
2208          (let ((info ((expr->accu info) expression)))
2209            (append-text info (wrap-as (i386:accu-zero?)))))
2210
2211         ;; FIXME: why do we get (post-inc ...) here
2212         ;; (array-ref
2213         (_ (let ((info ((expr->accu info) o)))
2214              (append-text info (wrap-as (i386:accu-zero?)))))))))
2215
2216 (define (enum-def-list->constants constants fields)
2217   (let loop ((fields fields) (i 0) (constants constants))
2218     (if (null? fields) constants
2219         (let* ((field (car fields))
2220                (name (pmatch field
2221                        ((enum-defn (ident ,name) . _) name)))
2222                (i (pmatch field
2223                     ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
2224                     ((enum-defn ,name) i)
2225                     ((enum-defn ,name (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2226                      (+ (cstring->number a) (cstring->number b)))
2227                     ((enum-defn ,name (sub (p-expr (fixed ,a)) (p-expr (fixed ,b))))
2228                      (- (cstring->number a) (cstring->number b)))
2229                     (_ (error "not supported enum field=~s\n" field)))))
2230           (loop (cdr fields)
2231                 (1+ i)
2232                 (append constants (list (ident->constant name i))))))))
2233
2234 (define (initzer->non-const info)
2235   (lambda (o)
2236     (pmatch o
2237       ((initzer (p-expr (ident ,name)))
2238        (let ((value (assoc-ref (.constants info) name)))
2239          `(initzer (p-expr (fixed ,(number->string value))))))
2240       (_ o))))
2241
2242 (define (initzer->data f g ta t d o)
2243   (pmatch o
2244     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2245     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2246     ((initzer (ref-to (p-expr (ident ,name))))
2247      (int->bv32 (+ ta (function-offset name f))))
2248     ((initzer (p-expr (string ,string)))
2249      (int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
2250     (_ (error "initzer->data: unsupported: " o))))
2251
2252 (define (.formals o)
2253   (pmatch o
2254     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2255     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2256     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2257     (_ (error ".formals: " o))))
2258
2259 (define (formal->text n)
2260   (lambda (o i)
2261     ;;(i386:formal i n)
2262     '()
2263     ))
2264
2265 (define (formals->text o)
2266   (pmatch o
2267     ((param-list . ,formals)
2268      (let ((n (length formals)))
2269        (wrap-as (append (i386:function-preamble)
2270                         (append-map (formal->text n) formals (iota n))
2271                         (i386:function-locals)))))
2272     (_ (error "formals->text: unsupported: " o))))
2273
2274 (define (formal:ptr o)
2275   (pmatch o
2276     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2277      0)
2278     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2279      2)
2280     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2281      1)
2282     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2283      1)
2284     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2285      2)
2286     (_
2287      (stderr "formal:ptr[~a] => ~a\n" o 0)
2288      0)))
2289
2290 (define (formals->locals o)
2291   (pmatch o
2292     ((param-list . ,formals)
2293      (let ((n (length formals)))
2294        (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2295     (_ (error "formals->locals: unsupported: " o))))
2296
2297 (define (function->info info)
2298   (lambda (o)
2299     (define (assert-return text)
2300       (let ((return (wrap-as (i386:ret))))
2301         (if (equal? (list-tail text (- (length text) (length return))) return) text
2302             (append text return))))
2303     (let* ((name (.name o))
2304            (formals (.formals o))
2305            (text (formals->text formals))
2306            (locals (formals->locals formals)))
2307       (format (current-error-port) "compiling: ~a\n" name)
2308       (let loop ((statements (.statements o))
2309                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2310         (if (null? statements) (clone info
2311                                       #:function #f
2312                                       #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2313             (let* ((statement (car statements)))
2314               (loop (cdr statements)
2315                     ((ast->info info) (car statements)))))))))
2316
2317 (define (ast-list->info info)
2318   (lambda (elements)
2319     (let loop ((elements elements) (info info))
2320       (if (null? elements) info
2321           (loop (cdr elements) ((ast->info info) (car elements)))))))
2322
2323 (define current-eval
2324   (let ((module (current-module)))
2325     (lambda (e) (eval e module))))
2326
2327 (define (object->list object)
2328   (text->list (map current-eval object)))
2329
2330 (define (dec->xhex o)
2331   (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
2332
2333 (define (write-lambda o)
2334   (newline)
2335   (display "    ")
2336   (if (or (not (pair? o))
2337           (not (eq? (caaddr o) 'list))) (write o)
2338           (list (car o) (cadr o)
2339                 (display (string-append "(lambda (f g ta t d) (list "
2340                                         (string-join (map dec->xhex (cdaddr o)) " ")
2341                                         "))")))))
2342
2343 (define (write-function o)
2344   (stderr "function: ~s\n" (car o))
2345   (newline)
2346   (display "  (")
2347   (write (car o)) (display " ")
2348   (if (not (cdr o)) (display ". #f")
2349       (for-each write-lambda (cdr o)))
2350   (display ")"))
2351
2352 (define (write-info o)
2353   (stderr "object:\n")
2354   (display "(make <info>\n")
2355   (display "  #:types\n  '") (pretty-print (.types o) #:width 80)
2356   (display "  #:constants\n  '") (pretty-print (.constants o) #:width 80)
2357   (display "  #:functions '(") (for-each write-function (.functions o)) (display ")") (newline)
2358   (stderr "globals:\n")
2359   (display "  #:globals\n  '") (pretty-print (.globals o) #:width 80)
2360   (stderr "init:\n")
2361   (display "  #:init\n  '") (pretty-print (.init o) #:width 80)
2362   (display ")\n"))
2363
2364 (define* (c99-input->info #:key (defines '()) (includes '()))
2365   (lambda ()
2366     (let* ((info (make <info> #:types i386:type-alist))
2367            (foo (stderr "parsing: input\n"))
2368            (ast (c99-input->ast #:defines defines #:includes includes))
2369            (foo (stderr "compiling: input\n"))
2370            (info ((ast->info info) ast))
2371            (info (clone info #:text '() #:locals '())))
2372       info)))
2373
2374 (define (write-any x)
2375   (write-char (cond ((char? x) x)
2376                     ((and (number? x) (< (+ x 256) 0))
2377                      (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
2378                     ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
2379                     ((procedure? x)
2380                      (stderr "write-any: proc: ~a\n" x)
2381                      (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
2382                      (error "procedure: write-any:" x))
2383                     (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
2384
2385 (define (info->elf info)
2386   (display "dumping elf\n" (current-error-port))
2387   (for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info))))
2388
2389 (define (function:object->text o)
2390   (cons (car o) (and (cdr o) (map current-eval (cdr o)))))
2391
2392 (define (init:object->text o)
2393   (current-eval o))
2394
2395 (define (info:object->text o)
2396   (clone o
2397          #:functions (map function:object->text (.functions o))
2398          #:init (map init:object->text (.init o))))
2399
2400 (define* (c99-ast->info ast)
2401   ((ast->info (make <info> #:types i386:type-alist)) ast))
2402
2403 (define* (c99-input->elf #:key (defines '()) (includes '()))
2404   ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
2405
2406 (define* (c99-input->object #:key (defines '()) (includes '()))
2407   ((compose write-info (c99-input->info #:defines defines #:includes includes))))
2408
2409 (define (object->elf info)
2410   ((compose info->elf info:object->text) info))
2411
2412 (define (infos->object infos)
2413   ((compose write-info merge-infos) infos))
2414
2415 (define (infos->elf infos)
2416   ((compose object->elf merge-infos) infos))
2417
2418 (define (merge-infos infos)
2419   (let loop ((infos infos) (info (make <info>)))
2420     (if (null? infos) info
2421         (loop (cdr infos)
2422               (clone info
2423                      #:types (alist-add (.types info) (.types (car infos)))
2424                      #:constants (alist-add (.constants info) (.constants (car infos)))
2425                      #:functions (alist-add (.functions info) (.functions (car infos)))
2426                      #:globals (alist-add (.globals info) (.globals (car infos)))
2427                      #:init (append (.init info) (.init (car infos))))))))
2428
2429 (define (alist-add a b)
2430   (let* ((b-keys (map car b))
2431          (a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a))
2432          (a-keys (map car a)))
2433     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))