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