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