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