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