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