mescc: cleanups.
[mes.git] / module / language / c99 / compiler.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; compiler.mes produces an i386 binary from the C produced by
24 ;;; Nyacc c99.
25
26 ;;; Code:
27
28 (cond-expand
29  (guile-2)
30  (guile)
31  (mes
32   (mes-use-module (srfi srfi-1))
33   (mes-use-module (srfi srfi-26))
34   (mes-use-module (mes pmatch))
35   (mes-use-module (nyacc lang c99 parser))
36   (mes-use-module (nyacc lang c99 pprint))
37   (mes-use-module (mes as))
38   (mes-use-module (mes as-i386))
39   (mes-use-module (mes M1))
40   (mes-use-module (mes optargs))
41   (mes-use-module (language c99 info))))
42
43 (define (logf port string . rest)
44   (apply format (cons* port string rest))
45   (force-output port)
46   #t)
47
48 (define (stderr string . rest)
49   (apply logf (cons* (current-error-port) string rest)))
50
51 (define (pke . stuff)
52   (newline (current-error-port))
53   (display ";;; " (current-error-port))
54   (write stuff (current-error-port))
55   (newline (current-error-port))
56   (car (last-pair stuff)))
57
58 (define (pke . stuff)
59   (car (last-pair stuff)))
60
61 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@"))
62
63 (define mes? (pair? (current-module)))
64
65 (define* (c99-input->full-ast #:key (defines '()) (includes '()))
66   (let ((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 (push-ident info)
596   (lambda (o)
597     (let ((local (assoc-ref (.locals info) o)))
598       (if local
599           (begin
600             (let* ((ptr (local:pointer local)))
601              (if (or (< ptr 0)) ((push-local-address (.locals info)) local)
602                  ((push-local (.locals info)) local))))
603           (let ((global (assoc-ref (.globals info) o)))
604             (if global
605                 ((push-global info) o) ;; FIXME: char*/int
606                 (let ((constant (assoc-ref (.constants info) o)))
607                   (if constant
608                       (wrap-as (append (i386:value->accu constant)
609                                        (i386:push-accu)))
610                       ((push-global-address #f) `(#:address ,o))))))))))
611
612 (define (push-ident-address info)
613   (lambda (o)
614     (let ((local (assoc-ref (.locals info) o)))
615       (if local ((push-local-address (.locals info)) local)
616           (let ((global (assoc-ref (.globals info) o)))
617           (if global
618               ((push-global-address info) o)
619               ((push-global-address #f) `(#:address ,o))))))))
620
621 (define (push-ident-de-ref info)
622   (lambda (o)
623     (let ((local (assoc-ref (.locals info) o)))
624       (if local ((push-local-de-ref info) local)
625           ((push-global-de-ref info) o)))))
626
627 (define (push-ident-de-de-ref info)
628   (lambda (o)
629     (let ((local (assoc-ref (.locals info) o)))
630       (if local ((push-local-de-de-ref info) local)
631           (error "TODO: global push-local-de-de-ref")))))
632
633 (define (expr->arg info)
634   (lambda (o)
635     (let ((info ((expr->accu info) o)))
636       (append-text info (wrap-as (i386:push-accu))))))
637
638 (define (globals:add-string globals)
639   (lambda (o)
640     (let ((string `(#:string ,o)))
641       (if (assoc-ref globals string) globals
642           (append globals (list (string->global-entry o)))))))
643
644 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
645   (lambda (o)
646     (let ((text (.text info)))
647       (pmatch o
648
649         ((p-expr (string ,string))
650          (let* ((globals ((globals:add-string (.globals info)) string))
651                 (info (clone info #:globals globals)))
652            (append-text info ((push-global-address info) `(#:string ,string)))))
653
654         ((p-expr (ident ,name))
655          (append-text info ((push-ident info) name)))
656
657         ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
658                           (abs-declr (pointer)))
659                ,cast)
660          ((expr->arg info) cast))
661
662         ((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast)
663          ((expr->arg info) cast))
664
665         ((de-ref (p-expr (ident ,name)))
666          (append-text info ((push-ident-de-ref info) name)))
667
668         ((de-ref (de-ref (p-expr (ident ,name))))
669          (append-text info ((push-ident-de-de-ref info) name)))
670
671         ((ref-to (p-expr (ident ,name)))
672          (append-text info ((push-ident-address info) name)))
673
674         (_ (append-text ((expr->accu info) o)
675                         (wrap-as (i386:push-accu))))))))
676
677 (define (ident->accu info)
678   (lambda (o)
679     (let ((local (assoc-ref (.locals info) o))
680           (global (assoc-ref (.globals info) o))
681           (constant (assoc-ref (.constants info) o)))
682       (if local
683           (let* ((ptr (local:pointer local))
684                  (type (ident->type info o))
685                  (size (if (= ptr 0) (ast-type->size info type)
686                            4)))
687             (cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id local))))
688                   (else (wrap-as (case size
689                                    ((1) (i386:byte-local->accu (local:id local)))
690                                    ((2) (i386:word-local->accu (local:id local)))
691                                    (else (i386:local->accu (local:id local))))))))
692           (if global
693               (let* ((ptr (ident->pointer info o)))
694                 (cond ((< ptr 0) (list (i386:label->accu `(#:address ,o))))
695                       (else (list (i386:label-mem->accu `(#:address ,o))))))
696               (if constant (wrap-as (i386:value->accu constant))
697                   (list (i386:label->accu `(#:address ,o)))))))))
698
699 (define (ident-address->accu info)
700   (lambda (o)
701     (let ((local (assoc-ref (.locals info) o))
702           (global (assoc-ref (.globals info) o))
703           (constant (assoc-ref (.constants info) o)))
704       (if local (wrap-as (i386:local-ptr->accu (local:id local)))
705           (if global (list (i386:label->accu `(#:address ,o)))
706               (list (i386:label->accu `(#:address ,o))))))))
707
708 (define (ident-address->base info)
709   (lambda (o)
710     (let ((local (assoc-ref (.locals info) o))
711           (global (assoc-ref (.globals info) o))
712           (constant (assoc-ref (.constants info) o)))
713       (if local (wrap-as (i386:local-ptr->base (local:id local)))
714           (if global (list (i386:label->base `(#:address ,o)))
715               (list (i386:label->base `(#:address ,o))))))))
716
717 (define (value->accu v)
718   (wrap-as (i386:value->accu v)))
719
720 (define (accu->ident info)
721   (lambda (o)
722     (let* ((local (assoc-ref (.locals info) o))
723            (ptr (ident->pointer info o))
724            (size (if (or (= ptr -1) (= ptr 0)) (ident->type-size info o)
725                      4)))
726       (if local (if (<= size 4) (wrap-as (i386:accu->local (local:id local)))
727                     (wrap-as (i386:accu*n->local (local:id local) size)))
728           (if (<= size 4) (wrap-as (i386:accu->label o))
729               (wrap-as (i386:accu*n->label o size)))))))
730
731 (define (value->ident info)
732   (lambda (o value)
733     (let ((local (assoc-ref (.locals info) o)))
734       (if local (wrap-as (i386:value->local (local:id local) value))
735           (list (i386:value->label `(#:address ,o) value))))))
736
737 (define (ident-add info)
738   (lambda (o n)
739     (let ((local (assoc-ref (.locals info) o)))
740       (if local (wrap-as (i386:local-add (local:id local) n))
741           (list (i386:label-mem-add `(#:address ,o) n))))))
742
743 (define (expr-add info)
744   (lambda (o n)
745     (let* ((info ((expr->accu* info) o))
746            (info (append-text info (wrap-as (i386:accu-mem-add n)))))
747       info)))
748
749 (define (ident-address-add info)
750   (lambda (o n)
751     (let ((local (assoc-ref (.locals info) o)))
752       (if local (wrap-as (append (i386:push-accu)
753                                  (i386:local->accu (local:id local))
754                                  (i386:accu-mem-add n)
755                                  (i386:pop-accu)))
756           (list (wrap-as (append (i386:push-accu)
757                                  (i386:label->accu `(#:address ,o))
758                                  (i386:accu-mem-add n)
759                                  (i386:pop-accu))))))))
760
761 (define (binop->accu info)
762   (lambda (a b c)
763     (let* ((info ((expr->accu info) a))
764            (info ((expr->base info) b)))
765       (append-text info (wrap-as c)))))
766
767 (define (wrap-as o . annotation)
768   `(,@annotation ,o))
769
770 (define (make-comment o)
771   (wrap-as `((#:comment ,o))))
772
773 (define (ast->comment o)
774   (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
775     (make-comment (string-join (string-split source #\newline) " "))))
776
777 (define (accu*n info n)
778   (append-text info (wrap-as (case n
779                                ((1) (i386:accu->base))
780                                ((2) (i386:accu+accu))
781                                ((3) (append (i386:accu->base)
782                                             (i386:accu+accu)
783                                             (i386:accu+base)))
784                                ((4) (i386:accu-shl 2))
785                                ((8) (append (i386:accu+accu)
786                                             (i386:accu-shl 2)))
787                                ((12) (append (i386:accu->base)
788                                              (i386:accu+accu)
789                                              (i386:accu+base)
790                                              (i386:accu-shl 2)))
791                                ((16) (i386:accu-shl 4))
792                                (else (append (i386:value->base n)
793                                              (i386:accu*base)))))))
794
795 (define (accu->base-mem*n- info n)
796   (wrap-as
797    (case n
798      ((1) (i386:byte-accu->base-mem))
799      ((2) (i386:word-accu->base-mem))
800      ((4) (i386:accu->base-mem))
801      (else (append (let loop ((i 0))
802                      (if (>= i n) '()
803                          (append (if (= i 0) '()
804                                      (append (i386:accu+value 4)
805                                              (i386:base+value 4)))
806                                  (case (- n i)
807                                    ((1) (append (i386:accu+value -3)
808                                                 (i386:base+value -3)
809                                                 (i386:accu-mem->base-mem)))
810                                    ((2) (append (i386:accu+value -2)
811                                                 (i386:base+value -2)
812                                                 (i386:accu-mem->base-mem)))
813                                    ((3) (append (i386:accu+value -1)
814                                                 (i386:base+value -1)
815                                                 (i386:accu-mem->base-mem)))
816                                    (else (i386:accu-mem->base-mem)))
817                                  (loop (+ i 4))))))))))
818
819 (define (accu->base-mem*n info n)
820   (append-text info (accu->base-mem*n- info n)))
821
822 (define (accu->local+n info local)
823   (lambda (n)
824     (let* ((type (local:type local))
825            (ptr (local:pointer local))
826            (size (if (= ptr -2) (ast-type->size info type)
827                      4))
828            (id (local:id local)))
829       (append-text info (wrap-as (case size
830                                    ((1) (i386:byte-accu->local+n id n))
831                                    ((2) (i386:word-accu->local+n id n))
832                                    (else (i386:accu->local+n id n))))))))
833
834 (define (expr->accu* info)
835   (lambda (o)
836     (pmatch o
837
838       ((p-expr (ident ,name))
839        (append-text info ((ident-address->accu info) name)))
840
841       ((de-ref ,expr)
842        ((expr->accu info) expr))
843
844       ((d-sel (ident ,field) ,struct)
845        (let* ((type (expr->type info struct))
846               (offset (field-offset info type field))
847               (info ((expr->accu* info) struct)))
848          (append-text info (wrap-as (i386:accu+value offset)))))
849
850       ((i-sel (ident ,field) ,struct)
851        (let* ((type (expr->type info struct))
852               (offset (field-offset info type field))
853               (info ((expr->accu* info) struct)))
854          (append-text info (append (wrap-as (i386:mem->accu))
855                                    (wrap-as (i386:accu+value offset))))))
856
857       ((array-ref ,index ,array)
858        (let* ((info ((expr->accu info) index))
859               (ptr (expr->pointer info array))
860               (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array)
861                         4))
862               (info (accu*n info size))
863               (info ((expr->base info) array)))
864          (append-text info (wrap-as (i386:accu+base)))))
865
866       (_ (error "expr->accu*: unsupported: " o)))))
867
868 (define (expr->accu info)
869   (lambda (o)
870     (let ((locals (.locals info))
871           (constants (.constants info))
872           (text (.text info))
873           (globals (.globals info)))
874       (define (add-local locals name type pointer)
875         (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
876                        (1+ (local:id (cdar locals)))))
877                (locals (cons (make-local-entry name type pointer id) locals)))
878           locals))
879       (pmatch o
880         ((expr) info)
881
882         ((comma-expr) info)
883
884         ((comma-expr ,a . ,rest)
885          (let ((info ((expr->accu info) a)))
886            ((expr->accu info) `(comma-expr ,@rest))))
887
888         ((p-expr (string ,string))
889          (let* ((globals ((globals:add-string globals) string))
890                 (info (clone info #:globals globals)))
891            (append-text info (list (i386:label->accu `(#:string ,string))))))
892
893         ;; FIXME: FROM INFO ...only zero?!
894         ((p-expr (fixed ,value))
895          (let ((value (cstring->number value)))
896            (append-text info (wrap-as (i386:value->accu value)))))
897
898         ((p-expr (char ,char))
899          (let ((char (char->integer (car (string->list char)))))
900            (append-text info (wrap-as (i386:value->accu char)))))
901
902         ((p-expr (string . ,strings))
903          (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings))))))
904
905         ((p-expr (ident ,name))
906          (append-text info ((ident->accu info) name)))
907
908         ((initzer ,initzer)
909          ((expr->accu info) initzer))
910
911         ;; offsetoff
912         ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
913          (let* ((type (decl->ast-type struct))
914                 (offset (field-offset info type field))
915                 (base (cstring->number base)))
916            (append-text info (wrap-as (i386:value->accu (+ base offset))))))
917
918         ;; &foo
919         ((ref-to (p-expr (ident ,name)))
920          (append-text info ((ident-address->accu info) name)))
921
922         ;; &*foo
923         ((ref-to (de-ref ,expr))
924          ((expr->accu info) expr))
925
926         ((ref-to ,expr)
927          ((expr->accu* info) expr))
928
929         ((sizeof-expr (p-expr (ident ,name)))
930          (let* ((type (ident->type info name))
931                 (size (ast-type->size info type)))
932            (append-text info (wrap-as (i386:value->accu size)))))
933
934         ((sizeof-expr (p-expr (string ,string)))
935          (append-text info (wrap-as (i386:value->accu (1+ (string-length string))))))
936
937         ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
938          (let* ((type (ident->type info struct))
939                 (size (field-size info type field)))
940            (append-text info (wrap-as (i386:value->accu size)))))
941
942         ((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct))))
943          (let* ((type (ident->type info struct))
944                 (size (field-size info type field)))
945            (append-text info (wrap-as (i386:value->accu size)))))
946
947         ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name)))))
948          (let* ((type name)
949                 (size (ast-type->size info type)))
950            (append-text info (wrap-as (i386:value->accu size)))))
951
952         ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type))))))
953          (let* ((type `("tag" ,type))
954                 (size (ast-type->size info type)))
955            (append-text info (wrap-as (i386:value->accu size)))))
956
957         ((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type)))))
958          (let ((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) (abs-declr (pointer))))
962          (let ((size 4))
963            (append-text info (wrap-as (i386:value->accu size)))))
964
965         ;; <expr>[baz]
966         ((array-ref ,index ,array)
967          (let* ((info ((expr->accu* info) o))
968                 (ptr (expr->pointer info array))
969                 (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array)
970                           4)))
971            (append-text info (wrap-as (case size
972                                         ((1) (i386:byte-mem->accu))
973                                         ((2) (i386:word-mem->accu))
974                                         ((4) (i386:mem->accu))
975                                         (else '()))))))
976
977         ((d-sel ,field ,struct)
978          (let* ((info ((expr->accu* info) o))
979                 (info (append-text info (ast->comment o)))
980                 (ptr (expr->pointer info o))
981                 (size (if (= ptr 0) (expr->type-size info o)
982                           4)))
983            (if (or (= -2 ptr) (= -1 ptr)) info
984                (append-text info (wrap-as (case size
985                                             ((1) (i386:byte-mem->accu))
986                                             ((2) (i386:word-mem->accu))
987                                             ((4) (i386:mem->accu))
988                                             (else '())))))))
989
990         ((i-sel ,field ,struct)
991          (let* ((info ((expr->accu* info) o))
992                 (info (append-text info (ast->comment o)))
993                 (ptr (expr->pointer info o))
994                 (size (if (= ptr 0) (expr->type-size info o)
995                           4)))
996            (if (or (= -2 ptr) (= ptr -1)) info
997                (append-text info (wrap-as (case size
998                                             ((1) (i386:byte-mem->accu))
999                                             ((2) (i386:word-mem->accu))
1000                                             ((4) (i386:mem->accu))
1001                                             (else '())))))))
1002
1003         ((de-ref ,expr)
1004          (let* ((info ((expr->accu info) expr))
1005                 (ptr (expr->pointer info expr))
1006                 (size (expr->size info o)))
1007            (append-text info (wrap-as (case size
1008                                         ((1) (i386:byte-mem->accu))
1009                                         ((2) (i386:word-mem->accu))
1010                                         ((4) (i386:mem->accu))
1011                                         (else '()))))))
1012
1013         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
1014          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1015                                    (append-text info (wrap-as (asm->m1 arg0))))
1016              (let* ((text-length (length text))
1017                     (args-info (let loop ((expressions (reverse expr-list)) (info info))
1018                                  (if (null? expressions) info
1019                                      (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1020                     (n (length expr-list)))
1021                (if (not (assoc-ref locals name))
1022                    (begin
1023                      (if (and (not (assoc name (.functions info)))
1024                               (not (assoc name globals))
1025                               (not (equal? name (.function info))))
1026                          (stderr "warning: undeclared function: ~a\n" name))
1027                      (append-text args-info (list (i386:call-label name n))))
1028                    (let* ((empty (clone info #:text '()))
1029                           (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1030                      (append-text args-info (append (.text accu)
1031                                                     (list (i386:call-accu n)))))))))
1032
1033         ((fctn-call ,function (expr-list . ,expr-list))
1034          (let* ((text-length (length text))
1035                 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1036                              (if (null? expressions) info
1037                                  (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1038                 (n (length expr-list))
1039                 (empty (clone info #:text '()))
1040                 (accu ((expr->accu empty) function)))
1041            (append-text args-info (append (.text accu)
1042                                           (list (i386:call-accu n))))))
1043
1044         ((cond-expr . ,cond-expr)
1045          ((ast->info info) `(expr-stmt ,o)))
1046
1047         ((post-inc ,expr)
1048          (let* ((info (append ((expr->accu info) expr)))
1049                 (info (append-text info (wrap-as (i386:push-accu))))
1050                 (ptr (expr->pointer info expr))
1051                 (size (cond ((= ptr 1) (expr->type-size info expr))
1052                             ((> ptr 1) 4)
1053                             (else 1)))
1054                 (info ((expr-add info) expr size))
1055                 (info (append-text info (wrap-as (i386:pop-accu)))))
1056            info))
1057
1058         ((post-dec ,expr)
1059          (let* ((info (append ((expr->accu info) expr)))
1060                 (info (append-text info (wrap-as (i386:push-accu))))
1061                 (ptr (expr->pointer info expr))
1062                 (size (cond ((= ptr 1) (expr->type-size info expr))
1063                             ((> ptr 1) 4)
1064                             (else 1)))
1065                 (info ((expr-add info) expr (- size)))
1066                 (info (append-text info (wrap-as (i386:pop-accu)))))
1067            info))
1068
1069         ((pre-inc ,expr)
1070          (let* ((ptr (expr->pointer info expr))
1071                 (size (cond ((= ptr 1) (expr->type-size info expr))
1072                             ((> ptr 1) 4)
1073                             (else 1)))
1074                 (info ((expr-add info) expr size))
1075                 (info (append ((expr->accu info) expr))))
1076            info))
1077
1078         ((pre-dec ,expr)
1079          (let* ((ptr (expr->pointer info expr))
1080                 (size (cond ((= ptr 1) (expr->type-size info expr))
1081                             ((> ptr 1) 4)
1082                             (else 1)))
1083                 (info ((expr-add info) expr (- size)))
1084                 (info (append ((expr->accu info) expr))))
1085            info))
1086
1087
1088
1089         ((add ,a (p-expr (fixed ,value)))
1090          ;;(stderr "add ~s\n"(with-output-to-string (lambda () (pretty-print-c99 o))))
1091          (let* ((ptr (pke "ptr" (expr->pointer info a)))
1092                 (type0 (expr->type info a))
1093                 (struct? (pke "struct" (memq (type:type (ast-type->type info type0)) '(struct union))))
1094                 (size (cond ((= ptr 1) (expr->type-size info a))
1095                             ((> ptr 1) 4)
1096                             ((and struct? (= ptr -2)) 4)
1097                             ((and struct? (= ptr 2)) 4)
1098                             (else 1)))
1099                 (info ((expr->accu info) a))
1100                 (value (cstring->number value))
1101                 (value (pke "VALUE" (* size value))))
1102            (pke "size" size)
1103            (append-text info (wrap-as (i386:accu+value value)))))
1104
1105         ((add ,a ,b)
1106          (let* ((ptr (expr->pointer info a))
1107                 (ptr-b (expr->pointer info b))
1108                 (type0 (expr->type info a))
1109                 (struct? (memq (type:type (ast-type->type info type0)) '(struct union)))
1110                 (size (cond ((= ptr 1) (expr->type-size info a))
1111                             ((> ptr 1) 4)
1112                             ((and struct? (= ptr -2)) 4)
1113                             ((and struct? (= ptr 2)) 4)
1114                             (else 1))))
1115            (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base))
1116                (let* ((info ((expr->accu info) b))
1117                       (info (append-text info (wrap-as (append (i386:value->base size)
1118                                                                (i386:accu*base)
1119                                                                (i386:accu->base)))))
1120                       (info ((expr->accu info) a)))
1121                  (append-text info (wrap-as (i386:accu+base)))))))
1122
1123         ((sub ,a (p-expr (fixed ,value)))
1124          (let* ((ptr (expr->pointer info a))
1125                 (type0 (expr->type info a))
1126                 (struct? (memq (type:type (ast-type->type info type0)) '(struct union)))
1127                 (size (cond ((= ptr 1) (expr->type-size info a))
1128                             ((> ptr 1) 4)
1129                             ((and struct? (= ptr -2)) 4)
1130                             ((and struct? (= ptr 2)) 4)
1131                             (else 1)))
1132                 (info ((expr->accu info) a))
1133                 (value (cstring->number value))
1134                 (value (* size value)))
1135            (append-text info (wrap-as (i386:accu+value (- value))))))
1136
1137         ((sub ,a ,b)
1138          ;;(stderr "sub ~s\n"(with-output-to-string (lambda () (pretty-print-c99 o))))
1139          (let* ((ptr (pke "ptr" (expr->pointer info a)))
1140                 (ptr-b (pke "ptr-b" (expr->pointer info b)))
1141                 (type0 (expr->type info a))
1142                 (struct? (pke "struct?" (memq (type:type (ast-type->type info type0)) '(struct union))))
1143                 (size  (cond ((= ptr 1) (expr->type-size info a))
1144                              ((> ptr 1) 4)
1145                              ((and struct? (= ptr -2)) 4)
1146                              ((and struct? (= ptr 2)) 4)
1147                              (else 1))))
1148            (pke "size" size)
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 ,cast ,o)
1227          ((expr->accu info) o))
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                 ;; (foo (stderr "assign ~s\n"(with-output-to-string (lambda () (pretty-print-c99 o)))))
1250                 ;; (foo (stderr "  size-a: ~a, ptr=~a\n" size-a ptr-a))
1251                 ;; (foo (stderr "  size-b: ~a, ptr=~a\n" size-b ptr-b))
1252                 (info ((expr->accu info) b))
1253                 (info (if (equal? op "=") info
1254                           (let* ((ptr (expr->pointer info a))
1255                                  (ptr-b (expr->pointer info b))
1256                                  (type0 (expr->type info a))
1257                                  (struct? (memq (type:type (ast-type->type info type0)) '(struct union)))
1258                                  (size (cond ((= ptr 1) (expr->type-size info a))
1259                                              ((> ptr 1) 4)
1260                                              ((and struct? (= ptr -2)) 4)
1261                                              ((and struct? (= ptr 2)) 4)
1262                                              (else 1)))
1263                                  (info (if (or (= size 1) (= ptr-b 1)) info
1264                                            (let ((info (append-text info (wrap-as (i386:value->base size)))))
1265                                              (append-text info (wrap-as (i386:accu*base))))))
1266                                  (info (append-text info (wrap-as (i386:push-accu))))
1267                                  (info ((expr->accu info) a))
1268                                  (info (append-text info (wrap-as (i386:pop-base))))
1269                                  (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
1270                                                                ((equal? op "-=") (wrap-as (i386:accu-base)))
1271                                                                ((equal? op "*=") (wrap-as (i386:accu*base)))
1272                                                                ((equal? op "/=") (wrap-as (i386:accu/base)))
1273                                                                ((equal? op "%=") (wrap-as (i386:accu%base)))
1274                                                                ((equal? op "&=") (wrap-as (i386:accu-and-base)))
1275                                                                ((equal? op "|=") (wrap-as (i386:accu-or-base)))
1276                                                                ((equal? op "^=") (wrap-as (i386:accu-xor-base)))
1277                                                                ((equal? op ">>=") (wrap-as (i386:accu>>base)))
1278                                                                ((equal? op "<<=") (wrap-as (i386:accu<<base)))
1279                                                                (else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
1280                             (cond ((not (and (= ptr 1) (= ptr-b 1))) info)
1281                                   ((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
1282                                                                                        (i386:accu/base)))))
1283                                   (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type0 (expr->type info b)))))))))
1284            (when (and (equal? op "=")
1285                       (not (= size-a size-b))
1286                       (not (and (or (= size-a 1) (= size-a 2))
1287                                 (= size-b 4)))
1288                       (not (and (= size-a 2)
1289                                 (= size-b 4)))
1290                       (not (and (= size-a 4)
1291                                 (or (= size-b 1) (= size-b 2)))))
1292              (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
1293              (stderr "   size[~a]:~a != size[~a]:~a\n"  ptr-a size-a ptr-b size-b))
1294            (pmatch a
1295              ((p-expr (ident ,name))
1296               (if (or (<= size-a 4) ;; FIXME: long long = int
1297                       (<= size-b 4)) (append-text info ((accu->ident info) name))
1298                       (let ((info ((expr->base* info) a)))
1299                         (accu->base-mem*n info size-a))))
1300              (_ (let ((info ((expr->base* info) a)))
1301                   (accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int
1302
1303         (_ (error "expr->accu: unsupported: " o))))))
1304
1305 (define (expr->base info)
1306   (lambda (o)
1307     (let* ((info (append-text info (wrap-as (i386:push-accu))))
1308            (info ((expr->accu info) o))
1309            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
1310       info)))
1311
1312 (define (expr->base* info)
1313   (lambda (o)
1314     (let* ((info (append-text info (wrap-as (i386:push-accu))))
1315            (info ((expr->accu* info) o))
1316            (info (append-text info (wrap-as (i386:accu->base))))
1317            (info (append-text info (wrap-as (i386:pop-accu)))))
1318       info)))
1319
1320 (define (clause->info info i label last?)
1321   (define clause-label
1322     (string-append label "clause" (number->string i)))
1323   (define body-label
1324     (string-append label "body" (number->string i)))
1325   (define (jump label)
1326     (wrap-as (i386:jump label)))
1327   (define (jump-nz label)
1328     (wrap-as (i386:jump-nz label)))
1329   (define (jump-z label)
1330     (wrap-as (i386:jump-z label)))
1331   (define (test->text test)
1332     (let ((value (pmatch test
1333                    (0 0)
1334                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
1335                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1336                    ((p-expr (fixed ,value)) (cstring->number value))
1337                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1338                    (_ (error "case test: unsupported: " test)))))
1339       (append (wrap-as (i386:accu-cmp-value value))
1340               (jump-z body-label))))
1341   (define (cases+jump info cases)
1342     (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
1343            (next-clause-label (if last? (string-append label "break")
1344                                   (string-append label "clause" (number->string (1+ i)))))
1345            (info (append-text info (apply append cases)))
1346            (info (if (null? cases) info
1347                      (append-text info (jump next-clause-label))))
1348            (info (append-text info (wrap-as `((#:label ,body-label))))))
1349       info))
1350
1351   (lambda (o)
1352     (let loop ((o o) (cases '()) (clause #f))
1353       (pmatch o
1354         ((case ,test ,statement)
1355          (loop statement (append cases (list (test->text test))) clause))
1356         ((default ,statement)
1357          (loop statement cases clause))
1358         ((default . ,statements)
1359          (loop `(compd-stmt (block-item-list ,@statements)) cases clause))
1360         ((compd-stmt (block-item-list))
1361          (loop '() cases clause))
1362         ((compd-stmt (block-item-list . ,elements))
1363          (let ((clause (or clause (cases+jump info cases))))
1364            (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1365                  ((ast->info clause) (car elements)))))
1366         (()
1367          (let ((clause (or clause (cases+jump info cases))))
1368            (if last? clause
1369                (let ((next-body-label (string-append label "body"
1370                                                      (number->string (1+ i)))))
1371                  (append-text clause (wrap-as (i386:jump next-body-label)))))))
1372         (_
1373          (let ((clause (or clause (cases+jump info cases))))
1374            (loop '() cases
1375                  ((ast->info clause) o))))))))
1376
1377 (define (test-jump-label->info info label)
1378   (define (jump type . test)
1379     (lambda (o)
1380       (let* ((info ((ast->info info) o))
1381              (info (append-text info (make-comment "jmp test LABEL")))
1382              (jump-text (wrap-as (type label))))
1383         (append-text info (append (if (null? test) '() (car test))
1384                                   jump-text)))))
1385   (lambda (o)
1386     (pmatch o
1387       ((expr) info)
1388       ;; unsigned
1389       ;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
1390       ;; ((lt ,a ,b) ((jump i386:jump-nc) o))  ; jae
1391       ;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
1392       ;; ((gt ,a ,b) ((jump i386:jump-nc) o))
1393
1394       ((le ,a ,b) ((jump i386:jump-g) o))
1395       ((lt ,a ,b) ((jump i386:jump-ge) o))
1396       ((ge ,a ,b) ((jump i386:jump-l) o))
1397       ((gt ,a ,b) ((jump i386:jump-le) o))
1398
1399       ((ne ,a ,b) ((jump i386:jump-nz) o))
1400       ((eq ,a ,b) ((jump i386:jump-nz) o))
1401       ((not _) ((jump i386:jump-z) o))
1402
1403       ((and ,a ,b)
1404        (let* ((info ((test-jump-label->info info label) a))
1405               (info ((test-jump-label->info info label) b)))
1406          info))
1407
1408       ((or ,a ,b)
1409        (let* ((here (number->string (length (.text info))))
1410               (skip-b-label (string-append label "_skip_b_" here))
1411               (b-label (string-append label "_b_" here))
1412               (info ((test-jump-label->info info b-label) a))
1413               (info (append-text info (wrap-as (i386:jump skip-b-label))))
1414               (info (append-text info (wrap-as `((#:label ,b-label)))))
1415               (info ((test-jump-label->info info label) b))
1416               (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1417          info))
1418
1419       ((array-ref ,index ,expr) (let* ((ptr (expr->pointer info expr))
1420                                        (size (if (= ptr 1) (ast-type->size info expr)
1421                                                  4)))
1422                                   ((jump (if (= size 1) i386:jump-byte-z
1423                                              i386:jump-z)
1424                                          (wrap-as (i386:accu-zero?))) o)))
1425
1426       ((de-ref ,expr) (let* ((ptr (expr->pointer info expr))
1427                              (size (if (= ptr 1) (ast-type->size info expr)
1428                                        4)))
1429                         ((jump (if (= size 1) i386:jump-byte-z
1430                                    i386:jump-z)
1431                                (wrap-as (i386:accu-zero?))) o)))
1432
1433       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1434        ((jump i386:jump-z
1435               (append ((ident->accu info) name)
1436                       (wrap-as (i386:accu-zero?)))) o))
1437
1438       (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
1439
1440 (define (cstring->number s)
1441   (let ((s (cond ((string-suffix? "ULL" s) (string-drop-right s 3))
1442                  ((string-suffix? "UL" s) (string-drop-right s 2))
1443                  ((string-suffix? "LL" s) (string-drop-right s 2))
1444                  ((string-suffix? "L" s) (string-drop-right s 1))
1445                  (else s))))
1446     (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1447           ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1448           ((string-prefix? "0" s) (string->number s 8))
1449           (else (string->number s)))))
1450
1451 (define (expr->number info o)
1452   (pmatch o
1453     ((p-expr (fixed ,a))
1454      (cstring->number a))
1455     ((neg ,a)
1456      (- (expr->number info a)))
1457     ((add ,a ,b)
1458      (+ (expr->number info a) (expr->number info b)))
1459     ((bitwise-and ,a ,b)
1460      (logand (expr->number info a) (expr->number info b)))
1461     ((bitwise-not ,a)
1462      (lognot (expr->number info a)))
1463     ((bitwise-or ,a ,b)
1464      (logior (expr->number info a) (expr->number info b)))
1465     ((div ,a ,b)
1466      (quotient (expr->number info a) (expr->number info b)))
1467     ((mul ,a ,b)
1468      (* (expr->number info a) (expr->number info b)))
1469     ((sub ,a ,b)
1470      (- (expr->number info a) (expr->number info b)))
1471     ((sizeof-type (type-name (decl-spec-list (type-spec ,type))))
1472      (ast-type->size info type))
1473     ((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct))))
1474      (let ((type (ident->type info struct)))
1475        (field-size info type field)))
1476     ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
1477      (let ((type (ident->type info struct)))
1478        (field-size info type field)))
1479     ((lshift ,x ,y)
1480      (ash (expr->number info x) (expr->number info y)))
1481     ((rshift ,x ,y)
1482      (ash (expr->number info x) (- (expr->number info y))))
1483     ((p-expr (ident ,name))
1484      (let ((value (assoc-ref (.constants info) name)))
1485        (or value
1486            (error (format #f "expr->number: undeclared identifier: ~s\n" o)))))
1487     ((cast ,type ,expr) (expr->number info expr))
1488     ((cond-expr ,test ,then ,else)
1489      (if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
1490     (_  (error (format #f "expr->number: not supported: ~s\n" o)))))
1491
1492 (define (p-expr->bool info o)
1493   (pmatch o
1494     ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b)))))
1495
1496 (define (struct-field info)
1497   (lambda (o)
1498     (pmatch o
1499       ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1500                   (comp-declr-list (comp-declr (ident ,name))))
1501        (list name `("tag" ,type) 4 0))
1502       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1503        (list name type (ast-type->size info type) 0))
1504       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1505        (list name type (ast-type->size info type) 0))
1506       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1507        (list name type 4 2))
1508       ((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)))))
1509        (list name type 4 1))
1510       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1511        (list name type 4 1))
1512       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1513        (list name type 4 2))
1514       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1515        (list name "void" 4 2))
1516       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1517        (list name "void" 4 1))
1518       ((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)))))
1519        (list name "void" 4 1))
1520       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1521        (list name type 4 1))
1522
1523       ;; FIXME: array: -1,-2-3, name??
1524       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
1525        (let ((size 4)
1526              (count (expr->number info count)))
1527          (list name type (* count size) -2)))
1528
1529       ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
1530        (let ((size (ast-type->size info type))
1531              (count (expr->number info count)))
1532          (list name type (* count size) -1)))
1533
1534       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1535        (list name `("tag" ,type) 4 2))
1536
1537       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1538        (list name `("tag" ,type) 4 1))
1539
1540       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1541        (let ((size (ast-type->size info `("tag" ,type))))
1542          (list name `("tag" ,type) size 0)))
1543
1544       ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
1545        `(struct ,@(map (struct-field info) fields)))
1546
1547       ((comp-decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1548        (let ((size (ast-type->size info `("tag" ,type))))
1549          (list name `("tag" ,type) size 0)))
1550
1551       ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
1552        `(union ,@(map (struct-field info) fields)))
1553
1554       (_ (error "struct-field: unsupported: " o)))))
1555
1556 (define (local-var? o) ;; formals < 0, locals > 0
1557   (positive? (local:id o)))
1558
1559 (define (ptr-declr->pointer o)
1560   (pmatch o
1561     ((pointer) 1)
1562     ((pointer (pointer)) 2)
1563     ((pointer (pointer (pointer))) 3)
1564     (_ (error "ptr-declr->pointer unsupported: " o))))
1565
1566 (define (init-declr->name o)
1567   (pmatch o
1568     ((ident ,name) name)
1569     ((ptr-declr ,pointer (ident ,name)) name)
1570     ((array-of (ident ,name)) name)
1571     ((array-of (ident ,name) ,index) name)
1572     ((ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)) name)
1573     ((ptr-declr (pointer) (array-of (ident ,name))) name)
1574     ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) name)
1575     (_ (error "init-declr->name unsupported: " o))))
1576
1577 (define (init-declr->count info o)
1578   (pmatch o
1579     ((array-of (ident ,name) ,count) (expr->number info count))
1580     (_ #f)))
1581
1582 (define (init-declr->pointer o)
1583   (pmatch o
1584     ((ident ,name) 0)
1585     ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer))
1586     ((array-of (ident ,name) ,index) -2)
1587     ((array-of (ident ,name)) -2)
1588     ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer))
1589     ((ptr-declr (pointer) (array-of (ident ,name))) -2)
1590     ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2)
1591     (_ (error "init-declr->pointer unsupported: " o))))
1592
1593 (define (statements->clauses statements)
1594   (let loop ((statements statements) (clauses '()))
1595     (if (null? statements) clauses
1596         (let ((s (car statements)))
1597           (pmatch s
1598             ((case ,test (compd-stmt (block-item-list . _)))
1599              (loop (cdr statements) (append clauses (list s))))
1600             ((case ,test (break))
1601              (loop (cdr statements) (append clauses (list s))))
1602             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1603
1604             ((case ,test ,statement)
1605              (let loop2 ((statement statement) (heads `((case ,test))))
1606                (define (heads->case heads statement)
1607                  (if (null? heads) statement
1608                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1609                (pmatch statement
1610                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1611                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1612                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1613                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1614                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1615                           (let ((s (car statements)))
1616                             (pmatch s
1617                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1618                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1619                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1620                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1621             ((default (compd-stmt (block-item-list _)))
1622              (loop (cdr statements) (append clauses (list s))))
1623             ((default . ,statement)
1624              (let loop2 ((statements (cdr statements)) (c statement))
1625                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1626                    (let ((s (car statements)))
1627                      (pmatch s
1628                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1629                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1630                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1631                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1632
1633                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1634             (_ (error "statements->clauses: unsupported:" s)))))))
1635
1636 (define (decl->info info)
1637   (lambda (o)
1638     (let ((functions (.functions info))
1639           (globals (.globals info))
1640           (locals (.locals info))
1641           (constants (.constants info))
1642           (types (.types info))
1643           (text (.text info)))
1644       (define (add-local locals name type pointer)
1645         (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
1646                        (1+ (local:id (cdar locals)))))
1647                (locals (cons (make-local-entry name type pointer id) locals)))
1648           locals))
1649       (define (declare name)
1650         (if (member name functions) info
1651             (clone info #:functions (cons (cons name #f) functions))))
1652       (pmatch o
1653
1654         ;; FIXME: Nyacc sometimes produces extra parens: (ident (<struct-name>))
1655         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1656          (declare name))
1657
1658         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1659          (clone info #:types (cons (cons name (get-type types type)) types)))
1660
1661         ;; int foo ();
1662         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1663          (declare name))
1664
1665         ;; void foo ();
1666         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1667          (declare name))
1668
1669         ;; void foo (*);
1670         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1671          (declare name))
1672
1673         ;; char *strcpy ();
1674         ((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))))))
1675          (declare name))
1676
1677         ;; printf (char const* format, ...)
1678         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1679          (declare name))
1680
1681         ;; <name> tcc_new
1682         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1683          (declare name))
1684
1685         ;; extern type foo ()
1686         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1687          (declare name))
1688
1689         ;; struct TCCState;
1690         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
1691          info)
1692
1693         ;; extern type global;
1694         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
1695          info)
1696
1697         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ident ,name))))
1698          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ident ,name)))))
1699          info)
1700
1701         ;; extern foo *bar;
1702         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1703          info)
1704
1705         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1706          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))))
1707
1708         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
1709         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1710          info)
1711
1712         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
1713         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
1714          info)
1715
1716         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
1717         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
1718          info)
1719
1720         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
1721         ;; Yay, let's hear it for the T-for Tiny in TCC!?
1722         ((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)))))
1723          info)
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 (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1729          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
1730
1731         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1732          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
1733
1734         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,value))))
1735          (let* ((type (get-type types type))
1736                 (value (expr->number info value))
1737                 (size (* value 4))
1738                 (pointer -1)
1739                 (type (make-type 'array size pointer type)))
1740            (clone info #:types (cons (cons name type) types))))
1741
1742         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
1743          (let* ((pointer (expr->pointer info pointer))
1744                 (type (or (get-type types type) `(typedef ,type)))
1745                 (size 4)
1746                 (type (make-type 'typedef size pointer type)))
1747            (clone info #:types (cons (cons name type) types))))
1748
1749         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1750          ((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))))))
1751
1752         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
1753          ((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))))))
1754
1755         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1756          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
1757                 (types (.types info)))
1758            (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
1759
1760         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
1761          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
1762                 (types (.types info)))
1763            (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
1764
1765         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1766          (let* ((type (get-type types type))
1767                 (type (make-type (type:type type)
1768                                  (type:size type)
1769                                  (1+ (type:pointer type))
1770                                  (type:description type)))
1771                 (type-entry (cons name type)))
1772            (clone info #:types (cons type-entry types))))
1773
1774         ;; struct
1775         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1776          (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
1777            (clone info #:types (cons type-entry types))))
1778
1779         ;; union
1780         ((decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))))
1781          (let ((type-entry (union->type-entry name (map (struct-field info) fields))))
1782            (clone info #:types (cons type-entry types))))
1783
1784         ;; enum e i;
1785         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1786          (let ((type "int")) ;; FIXME
1787            (if (.function info)
1788                (clone info #:locals (add-local locals name type 0))
1789                (clone info #:globals (append globals (list (ident->global-entry name type 0 0)))))))
1790
1791         ;; struct foo bar[2];
1792         ;; char arena[20000];
1793         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
1794          (let ((type (ast->type type)))
1795            (if (.function info)
1796                (let* ((local (car (add-local locals name type -1)))
1797                       (count (expr->number info count))
1798                       (size (ast-type->size info type))
1799                       (pointer (expr->pointer info `(type-spec ,type)))
1800                       (pointer (- -1 pointer))
1801                       (local (pke "0local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))))
1802                       (locals (cons local locals))
1803                       (info (clone info #:locals locals)))
1804                  info)
1805                (let* ((globals (.globals info))
1806                       (count (expr->number info count))
1807                       (size (ast-type->size info type))
1808                       (pointer (expr->pointer info `(type-spec ,type)))
1809                       (pointer (- -1 pointer))
1810                       (array (pke "0global: " (make-global-entry name type pointer (string->list (make-string (* count size) #\nul)))))
1811                       (globals (append globals (list array))))
1812                  (clone info #:globals globals)))))
1813
1814         ;; struct foo *bar[2];
1815         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
1816          (let ((type (ast->type type)))
1817            (if (.function info)
1818                (let* ((local (car (add-local locals name type -1)))
1819                       (count (expr->number info count))
1820                       (size 4)
1821                       (pointer (expr->pointer info `(type-spec ,type)))
1822                       (pointer (- -3 pointer))
1823                       (local (pke "1local:" (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))))
1824                       (locals (cons local locals))
1825                       (info (clone info #:locals locals)))
1826                  info)
1827                (let* ((globals (.globals info))
1828                       (count (expr->number info count))
1829                       (size 4)
1830                       (pointer (expr->pointer info `(type-spec ,type)))
1831                       (pointer (- -3 pointer))
1832                       (global (pke "1global: " (make-global-entry name type pointer (string->list (make-string (* count size) #\nul)))))
1833                       (globals (append globals (list global))))
1834                  (clone info #:globals globals)))))
1835
1836         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,array) (p-expr (fixed ,size))) (initzer (p-expr (string ,string))))))
1837          (if (.function info)
1838              (error  "TODO: " o)
1839              (let* ((globals (.globals info))
1840                     ;; (count (cstring->number count))
1841                     ;; (size (ast-type->size info type))
1842                     (array (make-global-entry array 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          (let* ((info (append-text info (ast->comment o)))
1900                 (type (decl->ast-type type))
1901                 (fields (ast-type->description info type))
1902                 (xtype (ast-type->type info type))
1903                 (fields (if (not (eq? (type:type xtype) 'union)) fields
1904                             (list-head fields 1)))
1905                 (size (ast-type->size info type))
1906                 (initzers (map (initzer->non-const info) initzers)))
1907            (if (.function info)
1908                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1909                       (global-names (map car globals))
1910                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1911                       (globals (append globals initzer-globals))
1912                       (local (car (add-local locals name type -1)))
1913                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) (quotient (+ size 3) 4))))
1914                       (locals (cons local locals))
1915                       (info (clone info #:locals locals #:globals globals))
1916                       (empty (clone info #:text '())))
1917                  (let loop ((fields fields) (initzers initzers) (info info))
1918                    (if (null? fields) info
1919                        (let ((offset (field-offset info type (field:name (car fields))))
1920                              (size (field:size (car fields)))
1921                              (initzer (if (null? initzers) '(p-expr (fixed "0")) (car initzers))))
1922                          (loop (cdr fields) (if (null? initzers) '() (cdr initzers))
1923                                (clone info #:text
1924                                       (append
1925                                        (.text info)
1926                                        ((ident->accu info) name)
1927                                        (wrap-as (append (i386:accu->base)))
1928                                        (.text ((expr->accu empty) initzer))
1929                                        (wrap-as (case size
1930                                                   ((1) (i386:byte-accu->base-mem+n offset))
1931                                                   ((2) (i386:word-accu->base-mem+n offset))
1932                                                   (else (i386:accu->base-mem+n offset)))))))))))
1933                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1934                       (global-names (map car globals))
1935                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1936                       (globals (append globals initzer-globals))
1937                       (global (make-global-entry name type -1 (append-map (initzer->data info) initzers)))
1938                       (globals (append globals (list global))))
1939                  (clone info #:globals globals)))))
1940
1941         ;; DECL
1942         ;; char *bla[] = {"a", "b"};
1943         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
1944          (let* ((type (decl->ast-type type))
1945                 (pointer (pke "2pointer: " (expr->pointer info `(type-spec ,type))))
1946                 (pointer (pke "pointer: " (- -3 pointer)))
1947                 (entries (filter identity (append-map (initzer->globals globals) initzers)))
1948                 (global-names (map car globals))
1949                 (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
1950                 (globals (append globals entries))
1951                 (entry-size 4)
1952                 (size (* (length entries) entry-size))
1953                 (initzers (map (initzer->non-const info) initzers)))
1954            (if (.function info)
1955                (let* ((count (length initzers))
1956                       (local (car (add-local locals name type -1)))
1957                       (local (pke "2local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (1+ count)))))
1958                       (locals (cons local locals))
1959                       (info (clone info #:locals locals))
1960                       (info (clone info #:globals globals))
1961                       (empty (clone info #:text '())))
1962                  (let loop ((index 0) (initzers initzers) (info info))
1963                    (if (null? initzers) info
1964                        (let ((offset (* index 4))
1965                              (initzer (car initzers)))
1966                          (loop (1+ index) (cdr initzers)
1967                                (clone info #:text
1968                                       (append
1969                                        (.text info)
1970                                        ((ident->accu info) name)
1971                                        (wrap-as (append (i386:accu->base)))
1972                                        (.text ((expr->accu empty) initzer))
1973                                        (wrap-as (i386:accu->base-mem+n offset)))))))))
1974                (let* ((global (pke "2global: " (make-global-entry name type pointer (append-map (initzer->data info) initzers))))
1975                       (globals (append globals (list global))))
1976                  (clone info #:globals globals)))))
1977
1978         ;; int foo[2] = { ... }
1979         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count) (initzer (initzer-list . ,initzers)))))
1980          (let* ((info (type->info info type))
1981                 (xtype type)
1982                 (type (decl->ast-type type))
1983                 (pointer (expr->pointer info `(type-spec ,type)))
1984                 (pointer (- -2 pointer))
1985                 (initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
1986                 (global-names (map car globals))
1987                 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
1988                 (initzers ((initzer->non-const info) initzers))
1989                 (info (append-text info (ast->comment o)))
1990                 (globals (append globals initzer-globals))
1991                 (info (clone info #:globals globals))
1992                 (type-size (if (<= pointer 0) (ast-type->size info type)
1993                                4))
1994                 (count (expr->number info count))
1995                 (size (* count type-size)))
1996            (if (.function info)
1997                (let* ((local (car (add-local locals name type 1)))
1998                       (local (pke "3local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))))
1999                       (locals (cons local locals))
2000                       (local (cdr local))
2001                       (info (clone info #:locals locals))
2002                       (info (let loop ((info info) (initzers initzers) (n 0))
2003                               (if (null? initzers) info
2004                                   (let* ((info ((initzer->accu info) (car initzers)))
2005                                          (info ((accu->local+n info local) n)))
2006                                     (loop info (cdr initzers) (+ n type-size)))))))
2007                  info)
2008                (let* ((global (pke "3global:" (make-global-entry name type pointer (append-map (initzer->data info) initzers))))
2009                       (globals (append globals (list global))))
2010                  (clone info #:globals globals)))))
2011
2012         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
2013          (let* ((info (type->info info type))
2014                 (xtype type)
2015                 (type (decl->ast-type type))
2016                 (name (init-declr->name init))
2017                 (pointer (pke "pointer:" (init-declr->pointer init)))
2018                 (initzer-globals (if (null? initzer) '()
2019                                      (filter identity (append-map (initzer->globals globals) initzer))))
2020                 (global-names (map car globals))
2021                 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2022                 (initzer (if (null? initzer) '() ((initzer->non-const info) initzer)))
2023                 (info (append-text info (ast->comment o)))
2024                 (globals (append globals initzer-globals))
2025                 (info (clone info #:globals globals))
2026                 (struct? (and (zero? pointer)
2027                               (or (and (pair? type) (equal? (car type) "tag"))
2028                                   (memq (type:type (ast-type->type info xtype)) '(struct union)))))
2029                 (pointer (if struct? -1 pointer))
2030                 (size (if (<= pointer 0) (ast-type->size info type)
2031                           4))
2032                 (count (init-declr->count info init)) ; array... split me up?
2033                 (size (if count (* count size) size)))
2034            (if (.function info)
2035                (let* ((locals (if (or (> pointer 0) (<= size 4)) (add-local locals name type pointer)
2036                                   (let* ((local (car (add-local locals name type 1)))
2037                                          (local (pke "4local:" (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))))
2038                                     (cons local locals))))
2039                       (info (clone info #:locals locals))
2040                       (info (if (null? initzer) info ((initzer->accu info) (car initzer))))
2041                       ;; FIXME array...struct?
2042                       (info (if (null? initzer) info (append-text info ((accu->ident info) name)))))
2043                  info)
2044                (let* ((global (pke "4global:" (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul))
2045                                                                         (append-map (initzer->data info) initzer)))))
2046                       (globals (append globals (list global))))
2047                  (clone info #:globals globals)))))
2048
2049         ;; int i = 0, j = 0;
2050         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2051          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2052            (if (null? inits) info
2053                (loop (cdr inits)
2054                      ((decl->info info)
2055                       `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2056
2057         ;; int *i = 0, j ..;
2058         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)) . ,initzer) . ,rest))
2059          (let loop ((inits `((init-declr (ptr-declr ,pointer (ident ,name)) ,@initzer) ,@rest)) (info info))
2060            (if (null? inits) info
2061                (loop (cdr inits)
2062                      ((decl->info info)
2063                       `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2064
2065         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2066          (format (current-error-port) "SKIP: typedef=~s\n" o)
2067          info)
2068
2069         ((decl (@ ,at))
2070          (format (current-error-port) "SKIP: at=~s\n" o)
2071          info)
2072
2073         ((decl . _) (error "decl->info: unsupported: " o))))))
2074
2075 (define (ast->info info)
2076   (lambda (o)
2077     (let ((functions (.functions info))
2078           (globals (.globals info))
2079           (locals (.locals info))
2080           (constants (.constants info))
2081           (types (.types info))
2082           (text (.text info)))
2083       (pmatch o
2084         (((trans-unit . _) . _)
2085          ((ast-list->info info)  o))
2086         ((trans-unit . ,elements)
2087          ((ast-list->info info) elements))
2088         ((fctn-defn . _) ((function->info info) o))
2089         ((cpp-stmt (define (name ,name) (repl ,value)))
2090          info)
2091
2092         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
2093          info)
2094
2095         ((break)
2096          (let ((label (car (.break info))))
2097            (append-text info (wrap-as (i386:jump label)))))
2098
2099         ((continue)
2100          (let ((label (car (.continue info))))
2101            (append-text info (wrap-as (i386:jump label)))))
2102
2103         ;; FIXME: expr-stmt wrapper?
2104         (trans-unit info)
2105         ((expr-stmt) info)
2106
2107         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
2108
2109         ((asm-expr ,gnuc (,null ,arg0 . string))
2110          (append-text info (wrap-as (asm->m1 arg0))))
2111
2112         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
2113          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
2114                                    (append-text info (wrap-as (asm->m1 arg0))))
2115              (let* ((info (append-text info (ast->comment o)))
2116                     (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
2117                (append-text info (wrap-as (i386:accu-zero?))))))
2118
2119         ((if ,test ,then)
2120          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
2121                 (here (number->string (length text)))
2122                 (label (string-append "_" (.function info) "_" here "_"))
2123                 (break-label (string-append label "break"))
2124                 (else-label (string-append label "else"))
2125                 (info ((test-jump-label->info info break-label) test))
2126                 (info ((ast->info info) then))
2127                 (info (append-text info (wrap-as (i386:jump break-label))))
2128                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2129            (clone info
2130                   #:locals locals)))
2131
2132         ((if ,test ,then ,else)
2133          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
2134                 (here (number->string (length text)))
2135                 (label (string-append "_" (.function info) "_" here "_"))
2136                 (break-label (string-append label "break"))
2137                 (else-label (string-append label "else"))
2138                 (info ((test-jump-label->info info else-label) test))
2139                 (info ((ast->info info) then))
2140                 (info (append-text info (wrap-as (i386:jump break-label))))
2141                 (info (append-text info (wrap-as `((#:label ,else-label)))))
2142                 (info ((ast->info info) else))
2143                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2144            (clone info
2145                   #:locals locals)))
2146
2147         ;; Hmm?
2148         ((expr-stmt (cond-expr ,test ,then ,else))
2149          (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
2150                 (here (number->string (length text)))
2151                 (label (string-append "_" (.function info) "_" here "_"))
2152                 (else-label (string-append label "else"))
2153                 (break-label (string-append label "break"))
2154                 (info ((test-jump-label->info info else-label) test))
2155                 (info ((ast->info info) then))
2156                 (info (append-text info (wrap-as (i386:jump break-label))))
2157                 (info (append-text info (wrap-as `((#:label ,else-label)))))
2158                 (info ((ast->info info) else))
2159                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2160            info))
2161
2162         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
2163          (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
2164                 (here (number->string (length text)))
2165                 (label (string-append "_" (.function info) "_" here "_"))
2166                 (break-label (string-append label "break"))
2167                 (clauses (statements->clauses statements))
2168                 (info ((expr->accu info) expr))
2169                 (info (clone info #:break (cons break-label (.break info))))
2170                 (info (let loop ((clauses clauses) (i 0) (info info))
2171                         (if (null? clauses) info
2172                             (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
2173                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2174            (clone info
2175                   #:locals locals
2176                   #:break (cdr (.break info)))))
2177
2178         ((for ,init ,test ,step ,body)
2179          (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
2180                 (here (number->string (length text)))
2181                 (label (string-append "_" (.function info) "_" here "_"))
2182                 (break-label (string-append label "break"))
2183                 (loop-label (string-append label "loop"))
2184                 (continue-label (string-append label "continue"))
2185                 (initial-skip-label (string-append label "initial_skip"))
2186                 (info ((ast->info info) init))
2187                 (info (clone info #:break (cons break-label (.break info))))
2188                 (info (clone info #:continue (cons continue-label (.continue info))))
2189                 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
2190                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2191                 (info ((ast->info info) body))
2192                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2193                 (info ((expr->accu info) step))
2194                 (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
2195                 (info ((test-jump-label->info info break-label) test))
2196                 (info (append-text info (wrap-as (i386:jump loop-label))))
2197                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2198            (clone info
2199                   #:locals locals
2200                   #:break (cdr (.break info))
2201                   #:continue (cdr (.continue info)))))
2202
2203         ((while ,test ,body)
2204          (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
2205                 (here (number->string (length text)))
2206                 (label (string-append "_" (.function info) "_" here "_"))
2207                 (break-label (string-append label "break"))
2208                 (loop-label (string-append label "loop"))
2209                 (continue-label (string-append label "continue"))
2210                 (info (append-text info (wrap-as (i386:jump continue-label))))
2211                 (info (clone info #:break (cons break-label (.break info))))
2212                 (info (clone info #:continue (cons continue-label (.continue info))))
2213                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2214                 (info ((ast->info info) body))
2215                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2216                 (info ((test-jump-label->info info break-label) test))
2217                 (info (append-text info (wrap-as (i386:jump loop-label))))
2218                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2219            (clone info
2220                   #:locals locals
2221                   #:break (cdr (.break info))
2222                   #:continue (cdr (.continue info)))))
2223
2224         ((do-while ,body ,test)
2225          (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
2226                 (here (number->string (length text)))
2227                 (label (string-append "_" (.function info) "_" here "_"))
2228                 (break-label (string-append label "break"))
2229                 (loop-label (string-append label "loop"))
2230                 (continue-label (string-append label "continue"))
2231                 (info (clone info #:break (cons break-label (.break info))))
2232                 (info (clone info #:continue (cons continue-label (.continue info))))
2233                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2234                 (info ((ast->info info) body))
2235                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2236                 (info ((test-jump-label->info info break-label) test))
2237                 (info (append-text info (wrap-as (i386:jump loop-label))))
2238                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2239            (clone info
2240                   #:locals locals
2241                   #:break (cdr (.break info))
2242                   #:continue (cdr (.continue info)))))
2243
2244         ((labeled-stmt (ident ,label) ,statement)
2245          (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label)))))))
2246            ((ast->info info) statement)))
2247
2248         ((goto (ident ,label))
2249          (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label)))))
2250
2251         ((return ,expr)
2252          (let ((info ((expr->accu info) expr)))
2253            (append-text info (append (wrap-as (i386:ret))))))
2254
2255         ((decl . ,decl)
2256          ((decl->info info) o))
2257
2258         ;; ...
2259         ((gt . _) ((expr->accu info) o))
2260         ((ge . _) ((expr->accu info) o))
2261         ((ne . _) ((expr->accu info) o))
2262         ((eq . _) ((expr->accu info) o))
2263         ((le . _) ((expr->accu info) o))
2264         ((lt . _) ((expr->accu info) o))
2265         ((lshift . _) ((expr->accu info) o))
2266         ((rshift . _) ((expr->accu info) o))
2267
2268         ;; EXPR
2269         ((expr-stmt ,expression)
2270          (let ((info ((expr->accu info) expression)))
2271            (append-text info (wrap-as (i386:accu-zero?)))))
2272
2273         ;; FIXME: why do we get (post-inc ...) here
2274         ;; (array-ref
2275         (_ (let ((info ((expr->accu info) o)))
2276              (append-text info (wrap-as (i386:accu-zero?)))))))))
2277
2278 (define (enum-def-list->constants constants fields)
2279   (let loop ((fields fields) (i 0) (constants constants))
2280     (if (null? fields) constants
2281         (let* ((field (car fields))
2282                (name (pmatch field
2283                        ((enum-defn (ident ,name) . _) name)))
2284                (i (pmatch field
2285                     ((enum-defn ,name) i)
2286                     ((enum-defn ,name ,exp) (expr->number #f exp))
2287                     (_ (error "not supported enum field=~s\n" field)))))
2288           (loop (cdr fields)
2289                 (1+ i)
2290                 (append constants (list (ident->constant name i))))))))
2291
2292 (define (initzer->non-const info)
2293   (lambda (o)
2294     (pmatch o
2295       ((initzer (p-expr (ident ,name)))
2296        (let ((value (assoc-ref (.constants info) name)))
2297          `(initzer (p-expr (fixed ,(number->string value))))))
2298       (_ o))))
2299
2300 (define (initzer->value info)
2301   (lambda (o)
2302     (pmatch o
2303       ((p-expr (fixed ,value)) (cstring->number value))
2304       (_ (error "initzer->value: " o)))))
2305
2306 (define (initzer->data info)
2307   (lambda (o)
2308     (pmatch o
2309       ((initzer (p-expr (char ,char))) (int->bv32 (char->integer (string-ref char 0))))
2310       ((initzer (p-expr (char ,char))) (list (char->integer (string-ref char 0))))
2311       ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
2312       ((initzer (p-expr (string . ,strings))) `((#:string ,(string-join strings "")) #f #f #f))
2313       ((initzer (initzer-list . ,initzers)) (append-map (initzer->data info) initzers))
2314       ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
2315       ((initzer (ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))))
2316        (let* ((type (decl->ast-type struct))
2317               (offset (field-offset info type field))
2318               (base (cstring->number base)))
2319          (int->bv32 (+ base offset))))
2320       (() (int->bv32 0))
2321       ((initzer ,p-expr)
2322        (int->bv32 (expr->number info p-expr)))
2323       (_ (error "initzer->data: unsupported: " o)))))
2324
2325 (define (initzer->accu info)
2326   (lambda (o)
2327     (pmatch o
2328       ((initzer-list . ,initzers) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2329       ((initzer (initzer-list . ,initzers)) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2330       ((initzer ,initzer) ((expr->accu info) o))
2331       (() (append-text info (wrap-as (i386:value->accu 0))))
2332       (_ (error "initzer->accu: " o)))))
2333
2334 (define (expr->global globals)
2335   (lambda (o)
2336     (pmatch o
2337       ((p-expr (string ,string))
2338        (let ((g `(#:string ,string)))
2339          (or (assoc g globals)
2340              (string->global-entry string))))
2341       ((p-expr (string . ,strings))
2342        (let* ((string (string-join strings ""))
2343               (g `(#:string ,string)))
2344          (or (assoc g globals)
2345              (string->global-entry string))))
2346       ;;((p-expr (fixed ,value)) (int->global-entry (cstring->number value)))
2347       (_ #f))))
2348
2349 (define (initzer->globals globals)
2350   (lambda (o)
2351     (pmatch o
2352       ((initzer (initzer-list . ,initzers)) (append-map (initzer->globals globals) initzers))
2353       ((initzer ,initzer) (list ((expr->global globals) initzer)))
2354       (_ '(#f)))))
2355
2356 (define (type->info info o)
2357   (pmatch o
2358     ((struct-def (ident ,name) (field-list . ,fields))
2359      (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
2360        (clone info #:types (cons type-entry (.types info)))))
2361     (_  info)))
2362
2363 (define (.formals o)
2364   (pmatch o
2365     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2366     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2367     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2368     ((fctn-defn _ (ptr-declr (pointer (pointer (pointer))) (ftn-declr _ ,formals)) _) formals)
2369     (_ (error ".formals: " o))))
2370
2371 (define (formal->text n)
2372   (lambda (o i)
2373     ;;(i386:formal i n)
2374     '()
2375     ))
2376
2377 (define (formals->text o)
2378   (pmatch o
2379     ((param-list . ,formals)
2380      (let ((n (length formals)))
2381        (wrap-as (append (i386:function-preamble)
2382                         (append-map (formal->text n) formals (iota n))
2383                         (i386:function-locals)))))
2384     (_ (error "formals->text: unsupported: " o))))
2385
2386 (define (formal:ptr o)
2387   (pmatch o
2388     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2389      0)
2390     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2391      2)
2392     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2393      1)
2394     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2395      1)
2396     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2397      2)
2398     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name))))
2399      3)
2400     (_ 0)))
2401
2402 (define (formals->locals o)
2403   (pmatch o
2404     ((param-list . ,formals)
2405      (let ((n (length formals)))
2406        (map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2407     (_ (error "formals->locals: unsupported: " o))))
2408
2409 (define (function->info info)
2410   (lambda (o)
2411     (define (assert-return text)
2412       (let ((return (wrap-as (i386:ret))))
2413         (if (equal? (list-tail text (- (length text) (length return))) return) text
2414             (append text return))))
2415     (let* ((name (.name o))
2416            (formals (.formals o))
2417            (text (formals->text formals))
2418            (locals (formals->locals formals)))
2419       (format (current-error-port) "    :~a\n" name)
2420       (let loop ((statements (.statements o))
2421                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2422         (if (null? statements) (let* ((locals (.locals info))
2423                                       (local (and (pair? locals) (car locals)))
2424                                       (count (and=> local (compose local:id cdr)))
2425                                       (stack (and count (* count 4))))
2426                                  (if (and stack (getenv "MESC_DEBUG")) (stderr "        stack: ~a\n" stack))
2427                                  (clone info
2428                                        #:function #f
2429                                        #:functions (append (.functions info) (list (cons name (assert-return (.text info)))))))
2430             (let* ((statement (car statements)))
2431               (loop (cdr statements)
2432                     ((ast->info info) (car statements)))))))))
2433
2434 ;; exports
2435
2436 (define (ast-list->info info)
2437   (lambda (elements)
2438     (let loop ((elements elements) (info info))
2439       (if (null? elements) info
2440           (loop (cdr elements) ((ast->info info) (car elements)))))))
2441
2442 (define* (c99-ast->info ast)
2443   ((ast->info (make <info> #:types i386:type-alist)) ast))
2444
2445 (define* (c99-input->ast #:key (defines '()) (includes '()))
2446   ((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:defines defines #:includes includes)))
2447
2448 (define* (c99-input->info #:key (defines '()) (includes '()))
2449   (lambda ()
2450     (let* ((info (make <info> #:types i386:type-alist))
2451            (foo (stderr "parsing: input\n"))
2452            (ast (c99-input->ast #:defines defines #:includes includes))
2453            (foo (stderr "compiling: input\n"))
2454            (info ((ast->info info) ast))
2455            (info (clone info #:text '() #:locals '())))
2456       info)))
2457
2458 (define* (info->object o)
2459   `((functions . ,(.functions o))
2460     (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2461
2462 (define* (c99-input->elf #:key (defines '()) (includes '()))
2463   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2464
2465 (define* (c99-input->object #:key (defines '()) (includes '()))
2466   ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))