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