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