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