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