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