6e70c86af37f6fa9105b6f4fc184d6dc68053b2f
[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)))) ;; FIXME: 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))))) ;; FIXME: 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 (p-expr (ident ,name)))
988               (let* ((type (ident->type info name))
989                      (ptr (ident->pointer info name))
990                      (size (if (= ptr 1) (ast-type->size info type)
991                                4)))
992                 (append-text info (append (wrap-as (i386:accu->base))
993                                           ((base->ident-address info) name)))))  ; FIXME: size
994              ((de-ref ,expr)
995               (let* ((info ((expr->base info) expr))
996                      (ptr (expr->pointer info expr))
997                      (size (expr->size info expr)))
998                 (append-text info (wrap-as (i386:accu->base-mem)))))
999              ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
1000               (let* ((info ((expr->base* info) a))
1001                      (type (ident->type info struct))
1002                      (offset (field-offset info type field))
1003                      (ptr (field-pointer info type field))
1004                      (type1 (field-type info type field))
1005                      (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type1)
1006                                4)))
1007                 (append-text info (case size
1008                                     ((1) (wrap-as (i386:byte-accu->base-mem)))
1009                                     ((2) (wrap-as (i386:word-accu->base-mem)))
1010                                     (else (wrap-as (i386:accu->base-mem)))))))
1011              ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
1012               (let* ((info ((expr->base* info) a))
1013                      (type (ident->type info struct))
1014                      (offset (field-offset info type field))
1015                      (ptr (field-pointer info type field))
1016                      (type1 (field-type info type field))
1017                      (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type1)
1018                                4)))
1019                 (append-text info (case size
1020                                     ((1) (wrap-as (i386:byte-accu->base-mem)))
1021                                     ((2) (wrap-as (i386:word-accu->base-mem)))
1022                                     (else (wrap-as (i386:accu->base-mem)))))))
1023              ((array-ref ,index (p-expr (ident ,array)))
1024               (let* ((type (ident->type info array))
1025                      (ptr (ident->pointer info array))
1026                      (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type)
1027                           4))
1028                      (info ((expr->base* info) a)))
1029                 (append-text info
1030                              (append (case size
1031                                        ((1) (wrap-as (i386:byte-accu->base-mem)))
1032                                        ((2) (wrap-as (i386:word-accu->base-mem)))
1033                                        (else (if (<= size 4) (wrap-as (i386:accu->base-mem))
1034                                                  (append
1035                                                   (wrap-as (i386:accu-mem->base-mem))
1036                                                   (wrap-as (append (i386:accu+value 4)
1037                                                                    (i386:base+value 4)
1038                                                                    (i386:accu-mem->base-mem)))
1039                                                   (if (<= size 8) '()
1040                                                       (wrap-as (append (i386:accu+value 4)
1041                                                                        (i386:base+value 4)
1042                                                                        (i386:accu-mem->base-mem))))))))))))
1043              (_ (error "expr->accu: unsupported assign: " a)))))
1044
1045         (_ (error "expr->accu: unsupported: " o))))))
1046
1047 (define (expr->base info)
1048   (lambda (o)
1049     (let* ((info (append-text info (wrap-as (i386:push-accu))))
1050            (info ((expr->accu info) o))
1051            (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
1052       info)))
1053
1054 (define (expr->base* info)
1055   (lambda (o)
1056     (let* ((info (append-text info (wrap-as (i386:push-accu))))
1057            (info ((expr->accu* info) o))
1058            (info (append-text info (wrap-as (i386:accu->base))))
1059            (info (append-text info (wrap-as (i386:pop-accu)))))
1060       info)))
1061
1062 (define (binop->accu info)
1063   (lambda (a b c)
1064     (let* ((info ((expr->accu info) a))
1065            (info ((expr->base info) b)))
1066       (append-text info (wrap-as c)))))
1067
1068 (define (wrap-as o . annotation)
1069   `(,@annotation ,o))
1070
1071 (define (make-comment o)
1072   (wrap-as `((#:comment ,o))))
1073
1074 (define (ast->comment o)
1075   (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
1076     (make-comment (string-join (string-split source #\newline) " "))))
1077
1078 (define (accu*value info value)
1079   (append-text info (wrap-as (case value
1080                                ((1) (i386:accu->base))
1081                                ((2) (i386:accu+accu))
1082                                ((3) (append (i386:accu->base)
1083                                             (i386:accu+accu)
1084                                             (i386:accu+base)))
1085                                ((4) (i386:accu-shl 2))
1086                                ((8) (append (i386:accu+accu)
1087                                             (i386:accu-shl 2)))
1088                                ((12) (append (i386:accu->base)
1089                                              (i386:accu+accu)
1090                                              (i386:accu+base)
1091                                              (i386:accu-shl 2)))
1092                                ((16) (i386:accu-shl 4))
1093                                (else (append (i386:value->base value)
1094                                              (i386:accu*base)))))))
1095
1096 (define (expr->accu* info)
1097   (lambda (o)
1098     (pmatch o
1099
1100       ((p-expr (ident ,name))
1101        (append-text info ((ident-address->accu info) name)))
1102
1103       ((de-ref ,expr)
1104        ((expr->accu info) expr))
1105
1106       ;; foo[bar]
1107       ((array-ref ,index (p-expr (ident ,array)))
1108        (let* ((type (ident->type info array))
1109               (ptr (ident->pointer info array))
1110               (size (if (or (= ptr 1) (= ptr -1)) (ast-type->size info type)
1111                         4))
1112               (info ((expr->accu info) index))
1113               (info (accu*value info size)))
1114          (append-text info (append ((ident->base info) array)
1115                                    (wrap-as (i386:accu+base))))))
1116
1117       ;; bar.foo.i
1118       ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1119        (let* ((type0 (ident->type info struct0))
1120               (type1 (field-type info type0 field0))
1121               (offset (+ (field-offset info type0 field0)
1122                          (field-offset info type1 field1))))
1123          (append-text info (append ((ident->accu info) struct0)
1124                                    (wrap-as (i386:accu+value offset))))))
1125
1126       ;; bar.poo->i
1127       ((i-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1128        (let* ((type0 (ident->type info struct0))
1129               (type1 (field-type info type0 field0))
1130               (offset0 (field-offset info type0 field0))
1131               (offset1 (field-offset info type1 field1)))
1132          (append-text info (append ((ident->accu info) struct0)
1133                                    (wrap-as (i386:accu+value offset0))
1134                                    (wrap-as (i386:mem->accu))
1135                                    (wrap-as (i386:accu+value offset1))))))
1136
1137       ;; bar->foo.i
1138       ((d-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0))))
1139        (let* ((type0 (ident->type info struct0))
1140               (type1 (field-type info type0 field0))
1141               (offset (+ (field-offset info type0 field0)
1142                          (field-offset info type1 field1)))
1143               (ptr0 (ident->pointer info struct0)))
1144          (append-text info (append ((ident->accu info) struct0)
1145                                    (wrap-as (i386:accu+value offset))))))
1146
1147       ;; bar->foo.i
1148       ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1149        (let* ((type0 (ident->type info struct0))
1150               (type1 (field-type info type0 field0))
1151               (offset (+ (field-offset info type0 field0)
1152                          (field-offset info type1 field1))))
1153          (append-text info (append ((ident->accu info) struct0)
1154                                    (wrap-as (i386:accu+value offset))))))
1155
1156       ;;(i-sel (ident "i") (i-sel (ident "p") (p-expr (ident "p"))))
1157       ((i-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0))))
1158        (let* ((type0 (ident->type info struct0))
1159               (type1 (field-type info type0 field0))
1160               (offset0 (field-offset info type0 field0))
1161               (offset1 (field-offset info type1 field1)))
1162          (append-text info (append ((ident->accu info) struct0)
1163                                    (wrap-as (i386:accu+value offset0))
1164                                    (wrap-as (i386:mem->accu))
1165                                    (wrap-as (i386:accu+value offset1))))))
1166
1167       ;; (*pp)->bar.foo
1168       ((d-sel (ident ,field1) (i-sel (ident ,field0) (de-ref (p-expr (ident ,struct0)))))
1169        (let* ((type0 (ident->type info struct0))
1170               (type1 (field-type info type0 field0))
1171               (offset (+ (field-offset info type0 field0)
1172                          (field-offset info type1 field1))))
1173          (append-text info (append ((ident->accu info) struct0)
1174                                    (wrap-as (i386:mem->accu))
1175                                    (wrap-as (i386:accu+value offset))))))
1176
1177       ;; g_cells[<expr>].type
1178       ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
1179        (let* ((type (ident->type info array))
1180               (offset (field-offset info type field))
1181               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1182          (append-text info (wrap-as (i386:accu+value offset)))))
1183
1184       ;; foo.bar
1185       ((d-sel (ident ,field) (p-expr (ident ,struct)))
1186        (let* ((type (ident->type info struct))
1187               (offset (field-offset info type field))
1188               (text (.text info))
1189               (ptr (field-pointer info type field)))
1190          (if (= ptr -1)
1191              (append-text info (append ((ident-address->accu info) struct)
1192                                        (wrap-as (i386:accu+value offset))))
1193              (append-text info (append ((ident->accu info) struct)
1194                                        (wrap-as (i386:accu+value offset)))))))
1195
1196       ;; foo.bar[baz]
1197       ((array-ref ,index (d-sel (ident ,field0) (p-expr (ident ,struct0))))
1198        (let* ((type0 (ident->type info struct0))
1199               (type1 (field-type info type0 field0))
1200               (offset (field-offset info type0 field0))
1201               (info ((expr->accu info) index))
1202               (struct? (or #t (memq (type:type (ast-type->type info type0)) '(struct union))))
1203               (ptr (field-pointer info type0 field0))
1204               (size (if (or (= ptr -1)
1205                             (= ptr 1)) (ast-type->size info type1)
1206                             4))
1207               (info (accu*value info size)))
1208          (append-text info (append (wrap-as (i386:push-accu))
1209                                    ((ident->accu info) struct0)
1210                                    (wrap-as (append (i386:accu+value offset)
1211                                                     (i386:pop-base)
1212                                                     (if (and struct? (or (= ptr -2) (= ptr 2)
1213                                                                          (= ptr 1)))
1214                                                         (i386:mem->accu) '())
1215                                                     (i386:accu+base)))))))
1216
1217       ;; foo->bar[baz]
1218       ((array-ref ,index (i-sel (ident ,field0) (p-expr (ident ,struct0))))
1219        (let* ((type0 (ident->type info struct0))
1220               (type1 (field-type info type0 field0))
1221               (offset (field-offset info type0 field0))
1222               (info ((expr->accu info) index))
1223               (struct? (or #t (memq (type:type (ast-type->type info type0)) '(struct union))))
1224               (ptr (field-pointer info type0 field0))
1225               (size (if (or (= ptr -1)
1226                             (= ptr 1)) (ast-type->size info type1)
1227                             4))
1228               (info (accu*value info size)))
1229          (append-text info (append (wrap-as (i386:push-accu))
1230                                    ((ident->accu info) struct0)
1231                                    (wrap-as (append (i386:accu+value offset)
1232                                                     (i386:pop-base)
1233                                                     (if (and struct? (or (= ptr -2) (= ptr 2)
1234                                                                          (= ptr 1)))
1235                                                         (i386:mem->accu) '())
1236                                                     (i386:accu+base)))))))
1237
1238       ((array-ref ,index ,array)
1239        (let* ((info ((expr->accu info) index))
1240               (ptr (expr->pointer info array))
1241               (size (if (= ptr 1) (expr->size info array)
1242                         4))
1243               (info (accu*value info size))
1244               (info ((expr->base info) array)))
1245           (append-text info (wrap-as (i386:accu+base)))))
1246
1247       ((i-sel (ident ,field) (p-expr (ident ,array)))
1248        (let* ((type (ident->type info array))
1249               (offset (field-offset info type field)))
1250          (append-text info (append ((ident-address->accu info) array)
1251                                    (wrap-as (i386:mem->accu))
1252                                    (wrap-as (i386:accu+value offset))))))
1253
1254       ((i-sel (ident ,field) (de-ref (p-expr (ident ,array))))
1255        (let* ((type (ident->type info array))
1256               (offset (field-offset info type field)))
1257          (append-text info (append ((ident-address->accu info) array)
1258                                    (wrap-as (i386:mem->accu))
1259                                    (wrap-as (i386:mem->accu))
1260                                    (wrap-as (i386:accu+value offset))))))
1261
1262       ;; foo[i].bar.baz
1263       ((d-sel (ident ,field1) (d-sel (ident ,field0) (array-ref ,index (p-expr (ident ,array)))))
1264          (let* ((type0 (ident->type info array))
1265                 (type1 (field-type info type0 field0))
1266                 (offset (+ (field-offset info type0 field0)
1267                            (field-offset info type1 field1)))
1268                 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1269            (append-text info (wrap-as (i386:accu+value offset)))))
1270
1271       ;;foo[index]->bar
1272       ((i-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
1273        (let* ((type (ident->type info array))
1274               (offset (field-offset info type field))
1275               (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
1276               (ptr (field-pointer info type field)))
1277          (append-text info (wrap-as (append (i386:mem->accu)
1278                                             (i386:accu+value offset))))))
1279
1280       (_ (error "expr->accu*: unsupported: " o)))))
1281
1282 (define (ident->constant name value)
1283   (cons name value))
1284
1285 (define (enum->type-entry name fields)
1286   (cons `("tag" ,name) (make-type 'enum 4 0 fields)))
1287
1288 (define (struct->type-entry name fields)
1289   (cons `("tag" ,name) (make-type 'struct (apply + (map field:size fields)) 0 fields)))
1290
1291 (define (union->type-entry name fields)
1292   (cons `("tag" ,name) (make-type 'union (apply + (map field:size fields)) 0 fields)))
1293
1294 (define i386:type-alist
1295   `(("char" . ,(make-type 'builtin 1 0 #f))
1296     ("short" . ,(make-type 'builtin 2 0 #f))
1297     ("int" . ,(make-type 'builtin 4 0 #f))
1298     ("long" . ,(make-type 'builtin 4 0 #f))
1299     ("long long" . ,(make-type 'builtin 8 0 #f))
1300     ("long long int" . ,(make-type 'builtin 8 0 #f))
1301     ("void" . ,(make-type 'builtin 1 0 #f))
1302     ;; FIXME sign
1303     ("unsigned char" . ,(make-type 'builtin 1 0 #f))
1304     ("unsigned short" . ,(make-type 'builtin 2 0 #f))
1305     ("unsigned short int" . ,(make-type 'builtin 2 0 #f))
1306     ("unsigned" . ,(make-type 'builtin 4 0 #f))
1307     ("unsigned int" . ,(make-type 'builtin 4 0 #f))
1308     ("unsigned long" . ,(make-type 'builtin 4 0 #f))
1309     ("unsigned long long" . ,(make-type 'builtin 8 0 #f))
1310     ("unsigned long long int" . ,(make-type 'builtin 8 0 #f))))
1311
1312 (define (field:name o)
1313   (pmatch o
1314     ((struct (,name ,type ,size ,pointer) . ,rest) name)
1315     ((union (,name ,type ,size ,pointer) . ,rest) name)
1316     ((,name ,type ,size ,pointer) name)
1317     (_ (error "field:name not supported:" o))))
1318
1319 (define (field:pointer o)
1320   (pmatch o
1321     ((struct (,name ,type ,size ,pointer) . ,rest) pointer)
1322     ((union (,name ,type ,size ,pointer) . ,rest) pointer)
1323     ((,name ,type ,size ,pointer) pointer)
1324     (_ (error "field:name not supported:" o))))
1325
1326 (define (field:size o)
1327   (pmatch o
1328     ((struct . ,fields) (apply + (map field:size fields)))
1329     ((union . ,fields) (apply max (map field:size fields)))
1330     ((,name ,type ,size ,pointer) size)
1331     (_ (error (format #f "field:size: ~s\n" o)))))
1332
1333 (define (field:type o)
1334   (pmatch o
1335     ((,name ,type ,size ,pointer) type)
1336     (_ (error (format #f "field:type: ~s\n" o)))))
1337
1338 (define (get-type types o)
1339   (let ((t (assoc-ref types o)))
1340     (pmatch t
1341       ((typedef ,next) (get-type types next))
1342       (_ t))))
1343
1344 (define (ast-type->type info o)
1345   (pmatch o
1346     ((p-expr ,expr) (ast-type->type info (p-expr->type info o)))
1347     ((pre-inc ,expr) (ast-type->type info expr))
1348     ((post-inc ,expr) (ast-type->type info expr))
1349     ((decl-spec-list ,type-spec)
1350      (ast-type->type info type-spec))
1351     ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
1352      (ast-type->type info type))
1353     ((struct-ref (ident (,type)))
1354      (let ((struct (if (pair? type) type `("tag" ,type))))
1355        (ast-type->type info struct)))
1356     ((struct-ref (ident ,type))
1357      (let ((struct (if (pair? type) type `("tag" ,type))))
1358        (ast-type->type info struct)))
1359     ((union-ref (ident ,type))
1360      (let ((struct (if (pair? type) type `("tag" ,type))))
1361        (ast-type->type info struct)))
1362     ((void) (ast-type->type info "void"))
1363     ((type-spec ,type) (ast-type->type info type))
1364     ((fixed-type ,type) (ast-type->type info type))
1365     ((typename ,type) (ast-type->type info type))
1366     ((d-sel (idend ,field) ,struct)
1367      (let ((type0 (ast-type->type info struct)))
1368        (field-type info type0 field)))
1369     ((i-sel (ident ,field) ,struct)
1370      (let ((type0 (ast-type->type info struct)))
1371        (field-type info type0 field)))
1372     (_ (let ((type (get-type (.types info) o)))
1373          (if type type
1374              (begin
1375                (stderr "types: ~s\n" (.types info))
1376                (error "ast-type->type: unsupported: " o)))))))
1377
1378 (define (ast-type->description info o)
1379   (let* ((type (ast-type->type info o))
1380          (xtype (if (type? type) type
1381                     (ast-type->type info type))))
1382     (type:description xtype)))
1383
1384 (define (ast-type->size info o)
1385   (let* ((type (ast-type->type info o))
1386          (xtype (if (type? type) type
1387                     (ast-type->type info type))))
1388     (type:size xtype)))
1389
1390 (define (field-field info struct field)
1391   (let* ((xtype (if (type? struct) struct
1392                     (ast-type->type info struct)))
1393          (fields (type:description xtype)))
1394     (let loop ((fields fields))
1395       (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
1396           (let ((f (car fields)))
1397             (cond ((equal? (car f) field) f)
1398                   ((and (memq (car f) '(struct union))
1399                         (find (lambda (x) (equal? (car x) field)) (cdr f))))
1400                   (else (loop (cdr fields)))))))))
1401
1402 (define (field-offset info struct field)
1403   (let ((xtype (if (type? struct) struct
1404                     (ast-type->type info struct))))
1405     (if (eq? (type:type xtype) 'union) 0
1406         (let ((fields (type:description xtype)))
1407           (let loop ((fields fields) (offset 0))
1408             (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
1409                 (let ((f (car fields)))
1410                   (cond ((equal? (car f) field) offset)
1411                         ((and (eq? (car f) 'struct)
1412                               (find (lambda (x) (equal? (car x) field)) (cdr f))
1413                               (apply + (cons offset
1414                                              (map field:size
1415                                                   (member field (reverse (cdr f))
1416                                                           (lambda (a b)
1417                                                             (equal? a (car b) field))))))))
1418                         ((and (eq? (car f) 'union)
1419                               (find (lambda (x) (equal? (car x) field)) (cdr f))
1420                               offset))
1421                         (else (loop (cdr fields) (+ offset (field:size f))))))))))))
1422
1423 (define (field-pointer info struct field)
1424   (let ((field (field-field info struct field)))
1425     (field:pointer field)))
1426
1427 (define (field-size info struct field)
1428   (let ((xtype (if (type? struct) struct
1429                    (ast-type->type info struct))))
1430     (if (eq? (type:type xtype) 'union) 0
1431         (let ((field (field-field info struct field)))
1432           (field:size field)))))
1433
1434 (define (field-type info struct field)
1435   (let ((field (field-field info struct field)))
1436     (field:type field)))
1437
1438 (define (ast->type o)
1439   (pmatch o
1440     ((fixed-type ,type)
1441      type)
1442     ((typename ,type)
1443      type)
1444     ((struct-ref (ident (,type)))
1445      `("tag" ,type))
1446     ((struct-ref (ident ,type))
1447      `("tag" ,type))
1448     (_ (stderr "SKIP: type=~s\n" o)
1449        "int")))
1450
1451 (define (decl->ast-type o)
1452   (pmatch o
1453     ((fixed-type ,type) type)
1454     ((struct-ref (ident (,name))) `("tag" ,name))
1455     ((struct-ref (ident ,name)) `("tag" ,name))
1456     ((struct-def (ident ,name) . ,fields) `("tag" ,name))
1457     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm"
1458      `("tag" ,name)) ;; FIXME
1459     ((typename ,name) name)
1460     (,name name)
1461     (_ (error "decl->ast-type: unsupported: " o))))
1462
1463 (define (byte->hex.m1 o)
1464   (string-drop o 2))
1465
1466 (define (asm->m1 o)
1467   (let ((prefix ".byte "))
1468     (if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
1469         (let ((s (string-drop o (string-length prefix))))
1470           (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
1471
1472 (define (clause->info info i label last?)
1473   (define clause-label
1474     (string-append label "clause" (number->string i)))
1475   (define body-label
1476     (string-append label "body" (number->string i)))
1477   (define (jump label)
1478     (wrap-as (i386:jump label)))
1479   (define (jump-nz label)
1480     (wrap-as (i386:jump-nz label)))
1481   (define (jump-z label)
1482     (wrap-as (i386:jump-z label)))
1483   (define (test->text test)
1484     (let ((value (pmatch test
1485                    (0 0)
1486                    ((p-expr (char ,value)) (char->integer (car (string->list value))))
1487                    ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
1488                    ((p-expr (fixed ,value)) (cstring->number value))
1489                    ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
1490                    (_ (error "case test: unsupported: " test)))))
1491       (append (wrap-as (i386:accu-cmp-value value))
1492               (jump-z body-label))))
1493   (define (cases+jump info cases)
1494     (let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
1495            (next-clause-label (if last? (string-append label "break")
1496                                   (string-append label "clause" (number->string (1+ i)))))
1497            (info (append-text info (apply append cases)))
1498            (info (if (null? cases) info
1499                      (append-text info (jump next-clause-label))))
1500            (info (append-text info (wrap-as `((#:label ,body-label))))))
1501       info))
1502
1503   (lambda (o)
1504     (let loop ((o o) (cases '()) (clause #f))
1505       (pmatch o
1506         ((case ,test ,statement)
1507          (loop statement (append cases (list (test->text test))) clause))
1508         ((default ,statement)
1509          (loop statement cases clause))
1510         ((default . ,statements)
1511          (loop `(compd-stmt (block-item-list ,@statements)) cases clause))
1512         ((compd-stmt (block-item-list))
1513          (loop '() cases clause))
1514         ((compd-stmt (block-item-list . ,elements))
1515          (let ((clause (or clause (cases+jump info cases))))
1516            (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
1517                  ((ast->info clause) (car elements)))))
1518         (()
1519          (let ((clause (or clause (cases+jump info cases))))
1520            (if last? clause
1521                (let ((next-body-label (string-append label "body"
1522                                                      (number->string (1+ i)))))
1523                  (append-text clause (wrap-as (i386:jump next-body-label)))))))
1524         (_
1525          (let ((clause (or clause (cases+jump info cases))))
1526            (loop '() cases
1527                  ((ast->info clause) o))))))))
1528
1529 (define (test-jump-label->info info label)
1530   (define (jump type . test)
1531     (lambda (o)
1532       (let* ((info ((ast->info info) o))
1533              (info (append-text info (make-comment "jmp test LABEL")))
1534              (jump-text (wrap-as (type label))))
1535         (append-text info (append (if (null? test) '() (car test))
1536                                   jump-text)))))
1537   (lambda (o)
1538     (pmatch o
1539       ;; unsigned
1540       ;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
1541       ;; ((lt ,a ,b) ((jump i386:jump-nc) o))  ; jae
1542       ;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
1543       ;; ((gt ,a ,b) ((jump i386:jump-nc) o))
1544
1545       ((le ,a ,b) ((jump i386:jump-g) o))
1546       ((lt ,a ,b) ((jump i386:jump-ge) o))
1547       ((ge ,a ,b) ((jump i386:jump-l) o))
1548       ((gt ,a ,b) ((jump i386:jump-le) o))
1549
1550       ((ne ,a ,b) ((jump i386:jump-nz) o))
1551       ((eq ,a ,b) ((jump i386:jump-nz) o))
1552       ((not _) ((jump i386:jump-z) o))
1553
1554       ((and ,a ,b)
1555        (let* ((info ((test-jump-label->info info label) a))
1556               (info ((test-jump-label->info info label) b)))
1557          info))
1558
1559       ((or ,a ,b)
1560        (let* ((here (number->string (length (.text info))))
1561               (skip-b-label (string-append label "_skip_b_" here))
1562               (b-label (string-append label "_b_" here))
1563               (info ((test-jump-label->info info b-label) a))
1564               (info (append-text info (wrap-as (i386:jump skip-b-label))))
1565               (info (append-text info (wrap-as `((#:label ,b-label)))))
1566               (info ((test-jump-label->info info label) b))
1567               (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
1568          info))
1569
1570       ((array-ref ,index ,expr) (let* ((ptr (expr->pointer info expr))
1571                                        (size (if (= ptr 1) (ast-type->size info expr)
1572                                                  4)))
1573                                   ((jump (if (= size 1) i386:jump-byte-z
1574                                              i386:jump-z)
1575                                          (wrap-as (i386:accu-zero?))) o)))
1576
1577       ((de-ref ,expr) (let* ((ptr (expr->pointer info expr))
1578                              (size (if (= ptr 1) (ast-type->size info expr)
1579                                        4)))
1580                         ((jump (if (= size 1) i386:jump-byte-z
1581                                    i386:jump-z)
1582                                (wrap-as (i386:accu-zero?))) o)))
1583
1584       ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1585        ((jump i386:jump-z
1586               (append ((ident->accu info) name)
1587                       (wrap-as (i386:accu-zero?)))) o))
1588
1589       (_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
1590
1591 (define (cstring->number s)
1592   (let ((s (cond ((string-suffix? "ULL" s) (string-drop-right s 3))
1593                  ((string-suffix? "UL" s) (string-drop-right s 2))
1594                  ((string-suffix? "LL" s) (string-drop-right s 2))
1595                  ((string-suffix? "L" s) (string-drop-right s 1))
1596                  (else s))))
1597     (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1598           ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1599           ((string-prefix? "0" s) (string->number s 8))
1600           (else (string->number s)))))
1601
1602 (define (p-expr->number info o)
1603   (pmatch o
1604     ((p-expr (fixed ,a))
1605      (cstring->number a))
1606     ((neg ,a)
1607      (- (p-expr->number info a)))
1608     ((add ,a ,b)
1609      (+ (p-expr->number info a) (p-expr->number info b)))
1610     ((bitwise-or ,a ,b)
1611      (logior (p-expr->number info a) (p-expr->number info b)))
1612     ((div ,a ,b)
1613      (quotient (p-expr->number info a) (p-expr->number info b)))
1614     ((mul ,a ,b)
1615      (* (p-expr->number info a) (p-expr->number info b)))
1616     ((sub ,a ,b)
1617      (- (p-expr->number info a) (p-expr->number info b)))
1618     ((sizeof-type (type-name (decl-spec-list (type-spec ,type))))
1619      (ast-type->size info type))
1620     ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
1621      (let ((type (ident->type info struct)))
1622        (field-size info type field)))
1623     ((lshift ,x ,y)
1624      (ash (p-expr->number info x) (p-expr->number info y)))
1625     ((rshift ,x ,y)
1626      (ash (p-expr->number info x) (- (p-expr->number info y))))
1627     ((p-expr (ident ,name))
1628      (let ((value (assoc-ref (.constants info) name)))
1629        (or value
1630            (error (format #f "p-expr->number: undeclared identifier: ~s\n" o)))))
1631     (_  (error (format #f "p-expr->number: not supported: ~s\n" o)))))
1632
1633 (define (struct-field info)
1634   (lambda (o)
1635     (pmatch o
1636       ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1637                   (comp-declr-list (comp-declr (ident ,name))))
1638        (list name `("tag" ,type) 4 0))
1639       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1640        (list name type (ast-type->size info type) 0))
1641       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1642        (list name type (ast-type->size info type) 0))
1643       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1644        (list name type 4 2))
1645       ((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)))))
1646        (list name type 4 1))
1647       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1648        (list name type 4 1))
1649       ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1650        (list name type 4 2))
1651       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1652        (list name "void" 4 2))
1653       ((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1654        (list name "void" 4 1))
1655       ((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)))))
1656        (list name "void" 4 1))
1657       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1658        (list name type 4 1))
1659       ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
1660        (let ((size 4)
1661              (count (p-expr->number info count)))
1662          (list name type (* count size) -1)))
1663       ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
1664        (let ((size (ast-type->size info type))
1665              (count (p-expr->number info count)))
1666          (list name type (* count size) -1)))
1667       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1668        (list name `("tag" ,type) 4 -2))
1669
1670       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1671        (list name `("tag" ,type) 4 -2))
1672
1673       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1674        (list name `("tag" ,type) 4 1))
1675
1676       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1677        (list name `("tag" ,type) 4 1))
1678
1679       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ident ,name))))
1680        ((struct-field info) `(comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))))
1681
1682       ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1683        (let ((size (ast-type->size info `("tag" ,type))))
1684          (list name `("tag" ,type) size 0)))
1685
1686       ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
1687        `(struct ,@(map (struct-field info) fields)))
1688
1689       ((comp-decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
1690        (let ((size (ast-type->size info `("tag" ,type))))
1691          (list name `("tag" ,type) size 0)))
1692
1693       ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
1694        `(union ,@(map (struct-field info) fields)))
1695
1696       (_ (error "struct-field: unsupported: " o)))))
1697
1698 (define (ident->decl info o)
1699   (or (assoc-ref (.locals info) o)
1700       (assoc-ref (.globals info) o)
1701       (assoc-ref (.constants info) o)
1702       (begin
1703         (stderr "NO IDENT: ~a\n" o)
1704         (assoc-ref (.functions info) o))))
1705
1706 (define (ident->type info o)
1707   (let ((type (ident->decl info o)))
1708     (cond ((global? type) (global:type type))
1709           ((local? type) (local:type type))
1710           ((assoc-ref (.constants info) o) "int")
1711           (else (stderr "ident->type ~s => ~s\n" o type)
1712                 (car type)))))
1713
1714 (define (ident->pointer info o)
1715   (let ((local (assoc-ref (.locals info) o)))
1716     (if local (local:pointer local)
1717         (let ((global (assoc-ref (.globals info) o)))
1718           (if global
1719               (global:pointer (ident->decl info o))
1720               0)))))
1721
1722 (define (ident->size info o)
1723   (let* ((type (ident->type info o))
1724          (xtype (ast-type->type info type)))
1725     (type:size xtype)))
1726
1727 (define (expr->pointer info o)
1728   (pmatch o
1729     ((p-expr (fixed ,value)) 0)
1730     ((p-expr (ident ,name)) (ident->pointer info name))
1731     ((de-ref ,expr) (1- (expr->pointer info expr)))
1732     ((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs))
1733     ((add ,a ,b) (expr->pointer info a))
1734     ((neg ,a) (expr->pointer info a))
1735     ((sub ,a ,b) (expr->pointer info a))
1736     ((pre-inc ,a) (expr->pointer info a))
1737     ((pre-dec ,a) (expr->pointer info a))
1738     ((post-inc ,a) (expr->pointer info a))
1739     ((post-dec ,a) (expr->pointer info a))
1740     ((ref-to ,expr) (1+ (expr->pointer info expr)))
1741     ((array-ref ,index ,array)
1742      (1- (expr->pointer info array)))
1743
1744     ((d-sel (ident ,field) (array-ref ,index ,array))
1745        (let ((type (p-expr->type info array)))
1746          (field-pointer info type field)))
1747
1748     ((i-sel (ident ,field) (array-ref ,index ,array))
1749        (let ((type (p-expr->type info array)))
1750          (field-pointer info type field)))
1751
1752     ((d-sel (ident ,field) (p-expr (ident ,struct)))
1753      (let ((type (ident->type info struct)))
1754        (field-pointer info type field)))
1755
1756     ((i-sel (ident ,field) (p-expr (ident ,struct)))
1757      (let ((type (ident->type info struct)))
1758        (field-pointer info type field)))
1759
1760     ((i-sel (ident ,field1) (i-sel (ident ,field0) ,struct0))
1761      (let* ((type0 (p-expr->type info struct0))
1762             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1763             (type1 (field-type info type0 field0)))
1764        (field-pointer info type1 field1)))
1765
1766     ((i-sel (ident ,field1) (d-sel (ident ,field0) ,struct0))
1767      (let* ((type0 (p-expr->type info struct0))
1768             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1769             (type1 (field-type info type0 field0)))
1770        (field-pointer info type1 field1)))
1771
1772     ((d-sel (ident ,field1) (i-sel (ident ,field0) ,struct0))
1773      (let* ((type0 (p-expr->type info struct0))
1774             ;;(type0 (if (pair? type0) type0 `("tag" ,type0)))
1775             (type1 (field-type info type0 field0)))
1776        (field-pointer info type1 field1)))
1777
1778     ((d-sel (ident ,field1) (d-sel (ident ,field0) ,struct0))
1779      (let* ((type0 (p-expr->type info struct0))
1780             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1781             (type1 (field-type info type0 field0)))
1782        (field-pointer info type1 field1)))
1783
1784     ((cast (type-name ,type) ,expr)     ; FIXME: add expr?
1785      (let* ((type (ast-type->type info type))
1786             (pointer (type:pointer type)))
1787        pointer))
1788     ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr?
1789      (let* ((type (ast-type->type info type))
1790             (pointer0 (type:pointer type))
1791             (pointer1 (ptr-declr->pointer pointer))
1792             (pointer2 (expr->pointer info expr)))
1793        (+ pointer0 pointer1)))
1794     (_ (stderr "expr->pointer: unsupported: ~s\n" o) 0)))
1795
1796 (define (expr->size info o)
1797   (pmatch o
1798     ((p-expr (ident ,name)) (ident->size info name))
1799
1800     ((array-ref ,index ,array)
1801      (let ((type (p-expr->type info array)))
1802        (ast-type->size info type)))
1803
1804     ((d-sel (ident ,field) (array-ref ,index ,array))
1805        (let ((type (p-expr->type info array)))
1806          (field-size info type field)))
1807
1808     ((i-sel (ident ,field) (array-ref ,index ,array))
1809        (let ((type (p-expr->type info array)))
1810          (field-size info type field)))
1811
1812     ((d-sel (ident ,field) (p-expr (ident ,struct)))
1813      (let* ((type (ident->type info struct))
1814             (type1 (field-type info type field)))
1815        (ast-type->size info type1)))
1816
1817     ((i-sel (ident ,field) (p-expr (ident ,struct)))
1818      (let* ((type (ident->type info struct))
1819             (type1 (field-type info type field)))
1820        (ast-type->size info type1)))
1821
1822     ((i-sel (ident ,field1) (i-sel (ident ,field0) ,struct0))
1823      (let* ((type0 (p-expr->type info struct0))
1824             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1825             (type1 (field-type info type0 field0)))
1826        (ast-type->size info type1)))
1827
1828     ((i-sel (ident ,field1) (d-sel (ident ,field0) ,struct0))
1829      (let* ((type0 (p-expr->type info struct0))
1830             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1831             (type1 (field-type info type0 field0)))
1832        (ast-type->size info type1)))
1833
1834     ((d-sel (ident ,field1) (i-sel (ident ,field0) ,struct0))
1835      (let* ((type0 (p-expr->type info struct0))
1836             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1837             (type1 (field-type info type0 field0)))
1838        (ast-type->size info type1)))
1839
1840     ((d-sel (ident ,field1) (d-sel (ident ,field0) ,struct0))
1841      (let* ((type0 (p-expr->type info struct0))
1842             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1843             (type1 (field-type info type0 field0)))
1844        (ast-type->size info type1)))
1845
1846     ((de-ref ,expr) (expr->size info expr))
1847     ((add ,a ,b) (expr->size info a))
1848     ((sub ,a ,b) (expr->size info a))
1849     ((pre-inc ,a) (expr->size info a))
1850     ((pre-dec ,a) (expr->size info a))
1851     ((post-inc ,a) (expr->size info a))
1852     ((post-dec ,a) (expr->size info a))
1853     ((cast (type-name ,type) ,expr)  ; FIXME: ignore expr?
1854      (let ((type (ast-type->type info type)))
1855        (type:size type)))
1856     ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
1857      (let ((type (ast-type->type info type)))
1858        (type:size type)))
1859     (_ (stderr "expr->size: unsupported: ~s\n" o) 4)))
1860
1861 (define (p-expr->type info o)
1862   (pmatch o
1863     ((p-expr (ident ,name)) (ident->type info name))
1864     ((array-ref ,index ,array)
1865      (p-expr->type info array))
1866     ((array-ref ,index (p-expr (ident ,array))) (ident->type info array))
1867     ((i-sel (ident ,field1) (i-sel (ident ,field0) ,struct0))
1868      (let* ((type0 (p-expr->type info struct0))
1869             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1870             (type1 (field-type info type0 field0)))
1871        (field-type info type1 field1)))
1872
1873     ((i-sel (ident ,field1) (d-sel (ident ,field0) ,struct0))
1874      (let* ((type0 (p-expr->type info struct0))
1875             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1876             (type1 (field-type info type0 field0)))
1877        (field-type info type1 field1)))
1878
1879     ((d-sel (ident ,field1) (i-sel (ident ,field0) ,struct0))
1880      (let* ((type0 (p-expr->type info struct0))
1881             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1882             (type1 (field-type info type0 field0)))
1883        (field-type info type1 field1)))
1884
1885     ((d-sel (ident ,field1) (d-sel (ident ,field0) ,struct0))
1886      (let* ((type0 (p-expr->type info struct0))
1887             (type0 (if (pair? type0) type0 `("tag" ,type0)))
1888             (type1 (field-type info type0 field0)))
1889        (field-type info type1 field1)))
1890
1891     ((i-sel (ident ,field) (p-expr (ident ,struct)))
1892      (let* ((type0 (ident->type info struct))
1893             (type0 (if (pair? type0) type0 `("tag" ,type0))))
1894        (field-type info type0 field)))
1895     ((d-sel (ident ,field) (p-expr (ident ,struct)))
1896      (let* ((type0 (ident->type info struct))
1897             (type0 (if (pair? type0) type0 `("tag" ,type0))))
1898        (field-type info type0 field)))
1899     ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
1900      (let* ((type0 (ident->type info array))
1901             (type0 (if (pair? type0) type0 `("tag" ,type0))))
1902        (field-type info type0 field)))
1903     ((de-ref ,expr) (p-expr->type info expr))
1904     ((ref-to ,expr) (p-expr->type info expr))
1905     ((add ,a ,b) (p-expr->type info a))
1906     ((sub ,a ,b) (p-expr->type info a))
1907     ((p-expr (fixed ,value)) "int")
1908     ((neg ,a) (p-expr->type info a))
1909     ((cast (type-name ,type) ,expr) ; FIXME: ignore expr?
1910      type)
1911     ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
1912      type)
1913     ((fctn-call (p-expr (ident ,name)))
1914      (stderr "TODO: p-expr->type: unsupported: ~s\n" o)
1915      "int")
1916     (_ ;;(error (format #f "p-expr->type: unsupported: ~s") o)
1917      (stderr "TODO: p-expr->type: unsupported: ~s\n" o)
1918      "int")))
1919
1920 (define (local-var? o) ;; formals < 0, locals > 0
1921   (positive? (local:id o)))
1922
1923 (define (ptr-declr->pointer o)
1924   (pmatch o
1925     ((pointer) 1)
1926     ((pointer (pointer)) 2)
1927     ((pointer (pointer (pointer))) 3)
1928     (_ (error "ptr-declr->pointer unsupported: " o))))
1929
1930 (define (init-declr->name o)
1931   (pmatch o
1932     ((ident ,name) name)
1933     ((ptr-declr ,pointer (ident ,name)) name)
1934     ((array-of (ident ,name)) name)
1935     ((array-of (ident ,name) ,index) name)
1936     ((ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)) name)
1937     ((ptr-declr (pointer) (array-of (ident ,name))) name)
1938     ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) name)
1939     (_ (error "init-declr->name unsupported: " o))))
1940
1941 (define (init-declr->count info o)
1942   (pmatch o
1943     ((array-of (ident ,name) ,count) (p-expr->number info count))
1944     (_ #f)))
1945
1946 (define (init-declr->pointer o)
1947   (pmatch o
1948     ((ident ,name) 0)
1949     ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer))
1950     ((array-of (ident ,name) ,index) -1)
1951     ((array-of (ident ,name)) -1)
1952     ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer))
1953     ((ptr-declr (pointer) (array-of (ident ,name))) -2)
1954     ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2)
1955     (_ (error "init-declr->pointer unsupported: " o))))
1956
1957 (define (statements->clauses statements)
1958   (let loop ((statements statements) (clauses '()))
1959     (if (null? statements) clauses
1960         (let ((s (car statements)))
1961           (pmatch s
1962             ((case ,test (compd-stmt (block-item-list . _)))
1963              (loop (cdr statements) (append clauses (list s))))
1964             ((case ,test (break))
1965              (loop (cdr statements) (append clauses (list s))))
1966             ((case ,test) (loop (cdr statements) (append clauses (list s))))
1967
1968             ((case ,test ,statement)
1969              (let loop2 ((statement statement) (heads `((case ,test))))
1970                (define (heads->case heads statement)
1971                  (if (null? heads) statement
1972                      (append (car heads) (list (heads->case (cdr heads) statement)))))
1973                (pmatch statement
1974                  ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1975                  ((default ,s2) (loop2 s2 (append heads `((default)))))
1976                  ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1977                  (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1978                       (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1979                           (let ((s (car statements)))
1980                             (pmatch s
1981                               ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1982                               ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1983                               ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1984                               (_ (loop3 (cdr statements) (append c (list s))))))))))))
1985             ((default (compd-stmt (block-item-list _)))
1986              (loop (cdr statements) (append clauses (list s))))
1987             ((default . ,statement)
1988              (let loop2 ((statements (cdr statements)) (c statement))
1989                (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1990                    (let ((s (car statements)))
1991                      (pmatch s
1992                        ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1993                        ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1994                        ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1995                        ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1996
1997                        (_ (loop2 (cdr statements) (append c (list s)))))))))
1998             (_ (error "statements->clauses: unsupported:" s)))))))
1999
2000 (define (decl->info info)
2001   (lambda (o)
2002     (let ((functions (.functions info))
2003           (globals (.globals info))
2004           (locals (.locals info))
2005           (constants (.constants info))
2006           (types (.types info))
2007           (text (.text info)))
2008       (define (add-local locals name type pointer)
2009         (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
2010                        (1+ (local:id (cdar locals)))))
2011                (locals (cons (make-local-entry name type pointer id) locals)))
2012           locals))
2013       (define (declare name)
2014         (if (member name functions) info
2015             (clone info #:functions (cons (cons name #f) functions))))
2016       (pmatch o
2017
2018         ;; FIXME: Nyacc sometimes produces extra parens: (ident (<struct-name>))
2019         ((decl (decl-spec-list (stor-spec ,spec) (type-spec (struct-ref (ident (,type))))) ,init)
2020          ((decl->info info) `(decl (decl-spec-list (stor-spec ,spec) (type-spec (struct-ref (ident ,type)))) ,init)))
2021         ((decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2022          ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))))
2023
2024         ((decl (decl-spec-list (type-spec (struct-def (ident (,type)) ,field-list))))
2025          ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
2026
2027         ((decl (decl-spec-list (stor-spec ,spec) (type-spec (union-ref (ident (,type))))) ,init)
2028          ((decl->info info) `(decl (decl-spec-list (stor-spec ,spec) (type-spec (union-ref (ident ,type)))) ,init)))
2029         ((decl (decl-spec-list (type-spec (union-def (ident (,type)) ,field-list))))
2030          ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
2031
2032         ((decl (decl-spec-list (type-spec (union-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name) ,initzer)))
2033          ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name) ,initzer)))))
2034
2035
2036         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2037          (declare name))
2038
2039         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2040          (clone info #:types (cons (cons name (get-type types type)) types)))
2041
2042         ;; int foo ();
2043         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2044          (declare name))
2045
2046         ;; void foo ();
2047         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2048          (declare name))
2049
2050         ;; void foo (*);
2051         ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
2052          (declare name))
2053
2054         ;; char *strcpy ();
2055         ((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))))))
2056          (declare name))
2057
2058         ;; printf (char const* format, ...)
2059         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
2060          (declare name))
2061
2062         ;; <name> tcc_new
2063         ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
2064          (declare name))
2065
2066         ;; extern type foo ()
2067         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2068          (declare name))
2069
2070         ;; struct TCCState;
2071         ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
2072          info)
2073
2074         ;; extern type global;
2075         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
2076          info)
2077
2078         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ident ,name))))
2079          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ident ,name)))))
2080          info)
2081
2082         ;; extern foo *bar;
2083         ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
2084          info)
2085
2086         ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
2087          ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))))
2088
2089         ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
2090         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
2091          info)
2092
2093         ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
2094         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
2095          info)
2096
2097         ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
2098         ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
2099          info)
2100
2101         ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
2102         ;; Yay, let's hear it for the T-for Tiny in TCC!?
2103         ((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)))))
2104          info)
2105
2106         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2107          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
2108
2109         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2110          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ("tag" ,type)))) types)))
2111
2112         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
2113          (clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
2114
2115         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,value))))
2116          (let* ((type (get-type types type))
2117                 (value (p-expr->number info value))
2118                 (size (* value 4))
2119                 (pointer -1)
2120                 (type (make-type 'array size pointer type)))
2121            (clone info #:types (cons (cons name type) types))))
2122
2123         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
2124          (let* ((pointer (expr->pointer info pointer))
2125                 (type (or (get-type types type) `(typedef ,type)))
2126                 (size 4)
2127                 (type (make-type 'typedef size pointer type)))
2128            (clone info #:types (cons (cons name type) types))))
2129
2130         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
2131          ((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))))))
2132
2133         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
2134          ((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))))))
2135
2136         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
2137          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list))))))
2138                 (types (.types info)))
2139            (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
2140
2141         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name))))
2142          (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list))))))
2143                 (types (.types info)))
2144            (clone info #:types (cons (cons name (or (get-type types `("tag" ,type)) `(typedef ,type))) types))))
2145
2146         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
2147          (let* ((type (get-type types type))
2148                 (type (make-type (type:type type)
2149                                  (type:size type)
2150                                  (1+ (type:pointer type))
2151                                  (type:description type)))
2152                 (type-entry (cons name type)))
2153            (clone info #:types (cons type-entry types))))
2154
2155         ;; struct
2156         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
2157          (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
2158            (clone info #:types (cons type-entry types))))
2159
2160         ;; union
2161         ((decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))))
2162          (let ((type-entry (union->type-entry name (map (struct-field info) fields))))
2163            (clone info #:types (cons type-entry types))))
2164
2165         ;; enum e i;
2166         ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
2167          (let ((type "int")) ;; FIXME
2168            (if (.function info)
2169                (clone info #:locals (add-local locals name type 0))
2170                (clone info #:globals (append globals (list (ident->global-entry name type 0 0)))))))
2171
2172         ;; struct foo bar[2];
2173         ;; char arena[20000];
2174         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
2175          (let ((type (ast->type type)))
2176            (if (.function info)
2177                (let* ((local (car (add-local locals name type -1)))
2178                       (count (p-expr->number info count))
2179                       (size (ast-type->size info type))
2180                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))
2181                       (locals (cons local locals))
2182                       (info (clone info #:locals locals)))
2183                  info)
2184                (let* ((globals (.globals info))
2185                       (count (p-expr->number info count))
2186                       (size (ast-type->size info type))
2187                       (array (make-global-entry name type -1 (string->list (make-string (* count size) #\nul))))
2188                       (globals (append globals (list array))))
2189                  (clone info #:globals globals)))))
2190
2191         ;; struct foo *bar[2];
2192         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
2193          (let ((type (ast->type type)))
2194            (if (.function info)
2195                (let* ((local (car (add-local locals name type -1)))
2196                       (count (p-expr->number info count))
2197                       (size 4)
2198                       (local (make-local-entry name type -2 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))
2199                       (locals (cons local locals))
2200                       (info (clone info #:locals locals)))
2201                  info)
2202                (let* ((globals (.globals info))
2203                       (count (p-expr->number info count))
2204                       (size 4)
2205                       (global (make-global-entry name type -2 (string->list (make-string (* count size) #\nul))))
2206                       (globals (append globals (list global))))
2207                  (clone info #:globals globals)))))
2208
2209         ((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))))))
2210          (if (.function info)
2211              (error  "TODO: " o)
2212              (let* ((globals (.globals info))
2213                     ;; (count (cstring->number count))
2214                     ;; (size (ast-type->size info type))
2215                     (array (make-global-entry array type -1 (string->list string)))
2216                     (globals (append globals (list array))))
2217                (clone info #:globals globals))))
2218
2219         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
2220         ((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))))
2221          (let* ((locals (add-local locals name type 1))
2222                 (info (clone info #:locals locals))
2223                 (empty (clone info #:text '()))
2224                 (accu ((expr->accu empty) initzer)))
2225            (clone info
2226                   #:text
2227                   (append text
2228                           (.text accu)
2229                           ((accu->ident info) name)
2230                           (wrap-as (append (i386:label->base `(#:address "_start"))
2231                                            (i386:accu+base))))
2232                   #:locals locals)))
2233
2234         ;; char *p = g_cells;
2235         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
2236          (let ((info (append-text info (ast->comment o)))
2237                (type (decl->ast-type type)))
2238            (if (.function info)
2239                (let* ((locals (add-local locals name type  1))
2240                       (info (clone info #:locals locals)))
2241                  (append-text info (append ((ident->accu info) value)
2242                                            ((accu->ident info) name))))
2243                (let ((globals (append globals (list (ident->global-entry name type 1 `(,value #f #f #f))))))
2244                  (clone info #:globals globals)))))
2245
2246         ;; enum foo { };
2247         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
2248          (let ((type-entry (enum->type-entry name fields))
2249                (constants (enum-def-list->constants constants fields)))
2250            (clone info
2251                   #:types (cons type-entry types)
2252                   #:constants (append constants (.constants info)))))
2253
2254         ;; enum {};
2255         ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
2256          (let ((constants (enum-def-list->constants constants fields)))
2257            (clone info
2258                   #:constants (append constants (.constants info)))))
2259
2260         ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
2261                (init-declr-list (init-declr (ident ,name))))
2262          (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
2263            ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
2264
2265         ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,fields))) (init-declr-list (init-declr (ident ,name))))
2266          (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,fields)))))))
2267            ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
2268
2269         ;; struct f = {...};
2270         ;; LOCALS!
2271         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2272          (let* ((info (append-text info (ast->comment o)))
2273                 (type (decl->ast-type type))
2274                 (fields (ast-type->description info type))
2275                 (xtype (ast-type->type info type))
2276                 (fields (if (not (eq? (type:type xtype) 'union)) fields
2277                             (list-head fields 1)))
2278                 (size (ast-type->size info type))
2279                 (initzers (map (initzer->non-const info) initzers)))
2280            (if (.function info)
2281                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
2282                       (global-names (map car globals))
2283                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2284                       (globals (append globals initzer-globals))
2285                       (local (car (add-local locals name type -1)))
2286                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) (quotient (+ size 3) 4))))
2287                       (locals (cons local locals))
2288                       (info (clone info #:locals locals #:globals globals))
2289                       (empty (clone info #:text '())))
2290                  (let loop ((fields fields) (initzers initzers) (info info))
2291                    (if (null? fields) info
2292                        (let ((offset (field-offset info type (field:name (car fields))))
2293                              (size (field:size (car fields)))
2294                              (initzer (if (null? initzers) '(p-expr (fixed "0")) (car initzers))))
2295                          (loop (cdr fields) (if (null? initzers) '() (cdr initzers))
2296                                (clone info #:text
2297                                       (append
2298                                        (.text info)
2299                                        ((ident->accu info) name)
2300                                        (wrap-as (append (i386:accu->base)))
2301                                        (.text ((expr->accu empty) initzer))
2302                                        (wrap-as (case size
2303                                                   ((1) (i386:byte-accu->base-mem+n offset))
2304                                                   ((2) (i386:word-accu->base-mem+n offset))
2305                                                   (else (i386:accu->base-mem+n offset)))))))))))
2306                (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
2307                       (global-names (map car globals))
2308                       (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2309                       (globals (append globals initzer-globals))
2310                       (global (make-global-entry name type -1 (append-map (initzer->data info) initzers)))
2311                       (globals (append globals (list global))))
2312                  (clone info #:globals globals)))))
2313
2314         ;; DECL
2315         ;; char *bla[] = {"a", "b"};
2316         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
2317          (let* ((type (decl->ast-type type))
2318                 (entries (filter identity (append-map (initzer->globals globals) initzers)))
2319                 (global-names (map car globals))
2320                 (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
2321                 (globals (append globals entries))
2322                 (entry-size 4)
2323                 (size (* (length entries) entry-size))
2324                 (initzers (map (initzer->non-const info) initzers)))
2325            (if (.function info)
2326                (let* ((count (length initzers))
2327                       (local (car (add-local locals name type -1)))
2328                       (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (1+ count))))
2329                       (locals (cons local locals))
2330                       (info (clone info #:locals locals))
2331                       (info (clone info #:globals globals))
2332                       (empty (clone info #:text '())))
2333                  (let loop ((index 0) (initzers initzers) (info info))
2334                    (if (null? initzers) info
2335                        (let ((offset (* index 4))
2336                              (initzer (car initzers)))
2337                          (loop (1+ index) (cdr initzers)
2338                                (clone info #:text
2339                                       (append
2340                                        (.text info)
2341                                        ((ident->accu info) name)
2342                                        (wrap-as (append (i386:accu->base)))
2343                                        (.text ((expr->accu empty) initzer))
2344                                        (wrap-as (i386:accu->base-mem+n offset)))))))))
2345                (let* ((global (make-global-entry name type -2 (append-map (initzer->data info) initzers)))
2346                       (globals (append globals (list global))))
2347                  (clone info #:globals globals)))))
2348
2349         ;; int foo[2] = { ... }
2350         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count) (initzer (initzer-list . ,initzers)))))
2351          (let* ((info (type->info info type))
2352                 (xtype type)
2353                 (type (decl->ast-type type))
2354                 (pointer -1)
2355                 (initzer-globals (filter identity (append-map (initzer->globals globals) initzers)))
2356                 (global-names (map car globals))
2357                 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2358                 (initzers ((initzer->non-const info) initzers))
2359                 (info (append-text info (ast->comment o)))
2360                 (globals (append globals initzer-globals))
2361                 (info (clone info #:globals globals))
2362                 (size 4)
2363                 (count (p-expr->number info count))
2364                 (size (* count size)))
2365            (if (.function info)
2366                (let* ((local (car (add-local locals name type 1)))
2367                       (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
2368                       (locals (cons local locals))
2369                       (info (clone info #:locals locals))
2370                       (info (let loop ((info info) (initzers initzers) (id (local:id (cdr local))))
2371                               (if (null? initzers) info
2372                                   (let* ((info ((initzer->accu info) (car initzers)))
2373                                          (info (append-text info (wrap-as (i386:accu->local id)))))
2374                                     (loop info (cdr initzers) (1- id)))))))
2375                  info)
2376                (let* ((global (make-global-entry name type pointer (append-map (initzer->data info) initzers)))
2377                       (globals (append globals (list global))))
2378                  (clone info #:globals globals)))))
2379
2380         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
2381          (let* ((info (type->info info type))
2382                 (xtype type)
2383                 (type (decl->ast-type type))
2384                 (name (init-declr->name init))
2385                 (pointer (init-declr->pointer init))
2386                 (initzer-globals (if (null? initzer) '()
2387                                      (filter identity (append-map (initzer->globals globals) initzer))))
2388                 (global-names (map car globals))
2389                 (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
2390                 (initzer (if (null? initzer) '() ((initzer->non-const info) initzer)))
2391                 (info (append-text info (ast->comment o)))
2392                 (globals (append globals initzer-globals))
2393                 (info (clone info #:globals globals))
2394                 (struct? (and (zero? pointer)
2395                               (or (and (pair? type) (equal? (car type) "tag"))
2396                                   (memq (type:type (ast-type->type info xtype)) '(struct union)))))
2397                 (pointer (if struct? -1 pointer))
2398                 (size (if (<= pointer 0) (ast-type->size info type)
2399                           4))
2400                 (count (init-declr->count info init)) ; array... split me up?
2401                 (size (if count (* count size) size)))
2402            (if (.function info)
2403                (let* ((locals (if (or (> pointer 0) (<= size 4)) (add-local locals name type pointer)
2404                                   (let* ((local (car (add-local locals name type 1)))
2405                                          (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))))
2406                                     (cons local locals))))
2407                       (info (clone info #:locals locals))
2408                       (info (if (null? initzer) info ((initzer->accu info) (car initzer))))
2409                       ;; FIXME array...struct?
2410                       (info (if (null? initzer) info (append-text info ((accu->ident info) name)))))
2411                  info)
2412                (let* ((global (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul))
2413                                                                        (append-map (initzer->data info) initzer))))
2414                       (globals (append globals (list global))))
2415                  (clone info #:globals globals)))))
2416
2417         ;; int i = 0, j = 0;
2418         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2419          (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2420            (if (null? inits) info
2421                (loop (cdr inits)
2422                      ((decl->info info)
2423                       `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits))))))))
2424
2425         ;; int *i = 0, j ..;
2426         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)) . ,initzer) . ,rest))
2427          (let loop ((inits `((init-declr (ptr-declr ,pointer (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         ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2434          (format (current-error-port) "SKIP: typedef=~s\n" o)
2435          info)
2436
2437         ((decl (@ ,at))
2438          (format (current-error-port) "SKIP: at=~s\n" o)
2439          info)
2440
2441         ((decl . _) (error "decl->info: unsupported: " o))))))
2442
2443 (define (ast->info info)
2444   (lambda (o)
2445     (let ((functions (.functions info))
2446           (globals (.globals info))
2447           (locals (.locals info))
2448           (constants (.constants info))
2449           (types (.types info))
2450           (text (.text info)))
2451       (pmatch o
2452         (((trans-unit . _) . _)
2453          ((ast-list->info info)  o))
2454         ((trans-unit . ,elements)
2455          ((ast-list->info info) elements))
2456         ((fctn-defn . _) ((function->info info) o))
2457         ((cpp-stmt (define (name ,name) (repl ,value)))
2458          info)
2459
2460         ((cast (type-name (decl-spec-list (type-spec (void)))) _)
2461          info)
2462
2463         ((break)
2464          (let ((label (car (.break info))))
2465            (append-text info (wrap-as (i386:jump label)))))
2466
2467         ((continue)
2468          (let ((label (car (.continue info))))
2469            (append-text info (wrap-as (i386:jump label)))))
2470
2471         ;; FIXME: expr-stmt wrapper?
2472         (trans-unit info)
2473         ((expr-stmt) info)
2474
2475         ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
2476
2477         ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
2478          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
2479                                    (append-text info (wrap-as (asm->m1 arg0))))
2480              (let* ((info (append-text info (ast->comment o)))
2481                     (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
2482                (append-text info (wrap-as (i386:accu-zero?))))))
2483
2484         ((if ,test ,then)
2485          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
2486                 (here (number->string (length text)))
2487                 (label (string-append (.function info) "_" here "_"))
2488                 (break-label (string-append label "break"))
2489                 (else-label (string-append label "else"))
2490                 (info ((test-jump-label->info info break-label) test))
2491                 (info ((ast->info info) then))
2492                 (info (append-text info (wrap-as (i386:jump break-label))))
2493                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2494            (clone info
2495                   #:locals locals)))
2496
2497         ((if ,test ,then ,else)
2498          (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
2499                 (here (number->string (length text)))
2500                 (label (string-append (.function info) "_" here "_"))
2501                 (break-label (string-append label "break"))
2502                 (else-label (string-append label "else"))
2503                 (info ((test-jump-label->info info else-label) test))
2504                 (info ((ast->info info) then))
2505                 (info (append-text info (wrap-as (i386:jump break-label))))
2506                 (info (append-text info (wrap-as `((#:label ,else-label)))))
2507                 (info ((ast->info info) else))
2508                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2509            (clone info
2510                   #:locals locals)))
2511
2512         ;; Hmm?
2513         ((expr-stmt (cond-expr ,test ,then ,else))
2514          (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
2515                 (here (number->string (length text)))
2516                 (label (string-append (.function info) "_" here "_"))
2517                 (else-label (string-append label "else"))
2518                 (break-label (string-append label "break"))
2519                 (info ((test-jump-label->info info else-label) test))
2520                 (info ((ast->info info) then))
2521                 (info (append-text info (wrap-as (i386:jump break-label))))
2522                 (info (append-text info (wrap-as `((#:label ,else-label)))))
2523                 (info ((ast->info info) else))
2524                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2525            info))
2526
2527         ((switch ,expr (compd-stmt (block-item-list . ,statements)))
2528          (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
2529                 (here (number->string (length text)))
2530                 (label (string-append (.function info) "_" here "_"))
2531                 (break-label (string-append label "break"))
2532                 (clauses (statements->clauses statements))
2533                 (info ((expr->accu info) expr))
2534                 (info (clone info #:break (cons break-label (.break info))))
2535                 (info (let loop ((clauses clauses) (i 0) (info info))
2536                         (if (null? clauses) info
2537                             (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
2538                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2539            (clone info
2540                   #:locals locals
2541                   #:break (cdr (.break info)))))
2542
2543         ((for ,init ,test ,step ,body)
2544          (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
2545                 (here (number->string (length text)))
2546                 (label (string-append (.function info) "_" here "_"))
2547                 (break-label (string-append label "break"))
2548                 (loop-label (string-append label "loop"))
2549                 (continue-label (string-append label "continue"))
2550                 (initial-skip-label (string-append label "initial_skip"))
2551                 (info ((ast->info info) init))
2552                 (info (clone info #:break (cons break-label (.break info))))
2553                 (info (clone info #:continue (cons continue-label (.continue info))))
2554                 (info (append-text info (wrap-as (i386:jump initial-skip-label))))
2555                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2556                 (info ((ast->info info) body))
2557                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2558                 (info ((expr->accu info) step))
2559                 (info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
2560                 (info ((test-jump-label->info info break-label) test))
2561                 (info (append-text info (wrap-as (i386:jump loop-label))))
2562                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2563            (clone info
2564                   #:locals locals
2565                   #:break (cdr (.break info))
2566                   #:continue (cdr (.continue info)))))
2567
2568         ((while ,test ,body)
2569          (let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
2570                 (here (number->string (length text)))
2571                 (label (string-append (.function info) "_" here "_"))
2572                 (break-label (string-append label "break"))
2573                 (loop-label (string-append label "loop"))
2574                 (continue-label (string-append label "continue"))
2575                 (info (append-text info (wrap-as (i386:jump continue-label))))
2576                 (info (clone info #:break (cons break-label (.break info))))
2577                 (info (clone info #:continue (cons continue-label (.continue info))))
2578                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2579                 (info ((ast->info info) body))
2580                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2581                 (info ((test-jump-label->info info break-label) test))
2582                 (info (append-text info (wrap-as (i386:jump loop-label))))
2583                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2584            (clone info
2585                   #:locals locals
2586                   #:break (cdr (.break info))
2587                   #:continue (cdr (.continue info)))))
2588
2589         ((do-while ,body ,test)
2590          (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
2591                 (here (number->string (length text)))
2592                 (label (string-append (.function info) "_" here "_"))
2593                 (break-label (string-append label "break"))
2594                 (loop-label (string-append label "loop"))
2595                 (continue-label (string-append label "continue"))
2596                 (info (clone info #:break (cons break-label (.break info))))
2597                 (info (clone info #:continue (cons continue-label (.continue info))))
2598                 (info (append-text info (wrap-as `((#:label ,loop-label)))))
2599                 (info ((ast->info info) body))
2600                 (info (append-text info (wrap-as `((#:label ,continue-label)))))
2601                 (info ((test-jump-label->info info break-label) test))
2602                 (info (append-text info (wrap-as (i386:jump loop-label))))
2603                 (info (append-text info (wrap-as `((#:label ,break-label))))))
2604            (clone info
2605                   #:locals locals
2606                   #:break (cdr (.break info))
2607                   #:continue (cdr (.continue info)))))
2608
2609         ((labeled-stmt (ident ,label) ,statement)
2610          (let ((info (append-text info `(((#:label ,(string-append (.function info) "_label_" label)))))))
2611            ((ast->info info) statement)))
2612
2613         ((goto (ident ,label))
2614          (append-text info (wrap-as (i386:jump (string-append (.function info) "_label_" label)))))
2615
2616         ((return ,expr)
2617          (let ((info ((expr->accu info) expr)))
2618            (append-text info (append (wrap-as (i386:ret))))))
2619
2620         ((decl . ,decl)
2621          ((decl->info info) o))
2622
2623         ;; ...
2624         ((gt . _) ((expr->accu info) o))
2625         ((ge . _) ((expr->accu info) o))
2626         ((ne . _) ((expr->accu info) o))
2627         ((eq . _) ((expr->accu info) o))
2628         ((le . _) ((expr->accu info) o))
2629         ((lt . _) ((expr->accu info) o))
2630         ((lshift . _) ((expr->accu info) o))
2631         ((rshift . _) ((expr->accu info) o))
2632
2633         ;; EXPR
2634         ((expr-stmt ,expression)
2635          (let ((info ((expr->accu info) expression)))
2636            (append-text info (wrap-as (i386:accu-zero?)))))
2637
2638         ;; FIXME: why do we get (post-inc ...) here
2639         ;; (array-ref
2640         (_ (let ((info ((expr->accu info) o)))
2641              (append-text info (wrap-as (i386:accu-zero?)))))))))
2642
2643 (define (enum-def-list->constants constants fields)
2644   (let loop ((fields fields) (i 0) (constants constants))
2645     (if (null? fields) constants
2646         (let* ((field (car fields))
2647                (name (pmatch field
2648                        ((enum-defn (ident ,name) . _) name)))
2649                (i (pmatch field
2650                     ((enum-defn ,name) i)
2651                     ((enum-defn ,name ,exp) (p-expr->number #f exp))
2652                     (_ (error "not supported enum field=~s\n" field)))))
2653           (loop (cdr fields)
2654                 (1+ i)
2655                 (append constants (list (ident->constant name i))))))))
2656
2657 (define (initzer->non-const info)
2658   (lambda (o)
2659     (pmatch o
2660       ((initzer (p-expr (ident ,name)))
2661        (let ((value (assoc-ref (.constants info) name)))
2662          `(initzer (p-expr (fixed ,(number->string value))))))
2663       (_ o))))
2664
2665 (define (initzer->value info)
2666   (lambda (o)
2667     (pmatch o
2668       ((p-expr (fixed ,value)) (cstring->number value))
2669       (_ (error "initzer->value: " o)))))
2670
2671 (define (initzer->data info)
2672   (lambda (o)
2673     (pmatch o
2674       ((initzer (p-expr (char ,char)))  (int->bv32 (char->integer (string-ref char 0))))
2675       ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
2676       ((initzer (p-expr (string . ,strings))) `((#:string ,(string-join strings "")) #f #f #f))
2677       ((initzer (initzer-list . ,initzers)) (append-map (initzer->data info) initzers))
2678       ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
2679       ((initzer (ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))))
2680        (let* ((type (decl->ast-type struct))
2681               (offset (field-offset info type field))
2682               (base (cstring->number base)))
2683          (int->bv32 (+ base offset))))
2684       (() (int->bv32 0))
2685       ((initzer ,p-expr)
2686        (int->bv32 (p-expr->number info p-expr)))
2687       (_ (error "initzer->data: unsupported: " o)))))
2688
2689 (define (initzer->accu info)
2690   (lambda (o)
2691     (pmatch o
2692       ((initzer-list . ,initzers) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2693       ((initzer (initzer-list . ,initzers)) (fold (lambda (i info) ((expr->accu info) i)) info initzers))
2694       ((initzer ,initzer) ((expr->accu info) o))
2695       (() (append-text info (wrap-as (i386:value->accu 0))))
2696       (_ (error "initzer->accu: " o)))))
2697
2698 (define (expr->global globals)
2699   (lambda (o)
2700     (pmatch o
2701       ((p-expr (string ,string))
2702        (let ((g `(#:string ,string)))
2703          (or (assoc g globals)
2704              (string->global-entry string))))
2705       ((p-expr (string . ,strings))
2706        (let* ((string (string-join strings ""))
2707               (g `(#:string ,string)))
2708          (or (assoc g globals)
2709              (string->global-entry string))))
2710       ;;((p-expr (fixed ,value)) (int->global-entry (cstring->number value)))
2711       (_ #f))))
2712
2713 (define (initzer->globals globals)
2714   (lambda (o)
2715     (pmatch o
2716       ((initzer (initzer-list . ,initzers)) (append-map (initzer->globals globals) initzers))
2717       ((initzer ,initzer) (list ((expr->global globals) initzer)))
2718       (_ '(#f)))))
2719
2720 (define (type->info info o)
2721   (pmatch o
2722     ((struct-def (ident ,name) (field-list . ,fields))
2723      (let ((type-entry (struct->type-entry name (map (struct-field info) fields))))
2724        (clone info #:types (cons type-entry (.types info)))))
2725     (_  info)))
2726
2727 (define (.formals o)
2728   (pmatch o
2729     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2730     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2731     ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2732     ((fctn-defn _ (ptr-declr (pointer (pointer (pointer))) (ftn-declr _ ,formals)) _) formals)
2733     (_ (error ".formals: " o))))
2734
2735 (define (formal->text n)
2736   (lambda (o i)
2737     ;;(i386:formal i n)
2738     '()
2739     ))
2740
2741 (define (formals->text o)
2742   (pmatch o
2743     ((param-list . ,formals)
2744      (let ((n (length formals)))
2745        (wrap-as (append (i386:function-preamble)
2746                         (append-map (formal->text n) formals (iota n))
2747                         (i386:function-locals)))))
2748     (_ (error "formals->text: unsupported: " o))))
2749
2750 (define (formal:ptr o)
2751   (pmatch o
2752     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2753      0)
2754     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2755      2)
2756     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2757      1)
2758     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2759      1)
2760     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2761      2)
2762     ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name))))
2763      3)
2764     (_ 0)))
2765
2766 (define (formals->locals o)
2767   (pmatch o
2768     ((param-list . ,formals)
2769      (let ((n (length formals)))
2770        (map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2771     (_ (error "formals->locals: unsupported: " o))))
2772
2773 (define (function->info info)
2774   (lambda (o)
2775     (define (assert-return text)
2776       (let ((return (wrap-as (i386:ret))))
2777         (if (equal? (list-tail text (- (length text) (length return))) return) text
2778             (append text return))))
2779     (let* ((name (.name o))
2780            (formals (.formals o))
2781            (text (formals->text formals))
2782            (locals (formals->locals formals)))
2783       (format (current-error-port) "    :~a\n" name)
2784       (let loop ((statements (.statements o))
2785                  (info (clone info #:locals locals #:function (.name o) #:text text)))
2786         (if (null? statements) (let* ((locals (.locals info))
2787                                       (local (and (pair? locals) (car locals)))
2788                                       (count (and=> local (compose local:id cdr)))
2789                                       (stack (and count (* count 4))))
2790                                  (if (and stack (getenv "MESC_DEBUG")) (stderr "        stack: ~a\n" stack))
2791                                  (clone info
2792                                        #:function #f
2793                                        #:functions (append (.functions info) (list (cons name (assert-return (.text info)))))))
2794             (let* ((statement (car statements)))
2795               (loop (cdr statements)
2796                     ((ast->info info) (car statements)))))))))
2797
2798 (define (ast-list->info info)
2799   (lambda (elements)
2800     (let loop ((elements elements) (info info))
2801       (if (null? elements) info
2802           (loop (cdr elements) ((ast->info info) (car elements)))))))
2803
2804 (define* (c99-input->info #:key (defines '()) (includes '()))
2805   (lambda ()
2806     (let* ((info (make <info> #:types i386:type-alist))
2807            (foo (stderr "parsing: input\n"))
2808            (ast (c99-input->ast #:defines defines #:includes includes))
2809            (foo (stderr "compiling: input\n"))
2810            (info ((ast->info info) ast))
2811            (info (clone info #:text '() #:locals '())))
2812       info)))
2813
2814 (define* (info->object o)
2815   `((functions . ,(.functions o))
2816     (globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
2817
2818 (define* (c99-ast->info ast)
2819   ((ast->info (make <info> #:types i386:type-alist)) ast))
2820
2821 (define* (c99-input->elf #:key (defines '()) (includes '()))
2822   ((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
2823
2824 (define* (c99-input->object #:key (defines '()) (includes '()))
2825   ((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))