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