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