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