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