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