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