3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;; This file is part of Mes.
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.
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.
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/>.
23 ;;; compiler.mes produces an i386 binary from the C produced by
30 (set-port-encoding! (current-output-port) "ISO-8859-1"))
33 (mes-use-module (mes pmatch))
34 (mes-use-module (nyacc lang c99 parser))
35 (mes-use-module (mes elf-util))
36 (mes-use-module (mes elf))
37 (mes-use-module (mes as-i386))
38 (mes-use-module (mes optargs))))
40 (define (logf port string . rest)
41 (apply format (cons* port string rest))
45 (define (stderr string . rest)
46 (apply logf (cons* (current-error-port) string rest)))
48 (define %datadir (if (string-prefix? "@DATADIR" "@DATADIR@") "" "@DATADIR@"))
49 (define %docdir (if (string-prefix? "@DOCDIR" "@DOCDIR@") "doc/" "@DOCDIR@"))
50 (define %moduledir "module/")
51 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
52 (define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
54 (define mes? (pair? (current-module)))
56 (define* (c99-input->ast #:key (defines '()) (includes '()))
58 #:inc-dirs (append includes (cons* "." "libc/include" "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:)))
64 "__NYACC__=1" ;; REMOVEME
76 ,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
78 ,(string-append "DATADIR=\"" %datadir "\"")
79 ,(string-append "DOCDIR=\"" %docdir "\"")
80 ,(string-append "PREFIX=\"" %prefix "\"")
81 ,(string-append "MODULEDIR=\"" %moduledir "\"")
82 ,(string-append "VERSION=\"" %version "\"")
87 (define (ast:function? o)
88 (and (pair? o) (eq? (car o) 'fctn-defn)))
92 ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
93 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
94 ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) _) name)
95 ((param-decl _ (param-declr (ident ,name))) name)
96 ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
97 ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
98 ((param-decl _ (param-declr (ptr-declr (pointer (pointer)) (ident ,name)))) name)
100 (format (current-error-port) "SKIP: .name =~a\n" o))))
104 ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
105 ((param-decl ,type _) type)
107 (format (current-error-port) "SKIP: .type =~a\n" o))))
109 (define (.statements o)
111 ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
112 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
113 ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
114 (_ (error ".statements: unsupported: " o))))
116 (define <info> '<info>)
117 (define <types> '<types>)
118 (define <constants> '<constants>)
119 (define <functions> '<functions>)
120 (define <globals> '<globals>)
121 (define <init> '<init>)
122 (define <locals> '<locals>)
123 (define <function> '<function>)
124 (define <text> '<text>)
125 (define <break> '<break>)
127 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()) (break '()))
131 (cons <constants> constants)
132 (cons <functions> functions)
133 (cons <globals> globals)
135 (cons <locals> locals)
136 (cons <function> function)
138 (cons <break> break)))))
142 ((<info> . ,alist) (assq-ref alist <types>))))
144 (define (.constants o)
146 ((<info> . ,alist) (assq-ref alist <constants>))))
148 (define (.functions o)
150 ((<info> . ,alist) (assq-ref alist <functions>))))
154 ((<info> . ,alist) (assq-ref alist <globals>))))
158 ((<info> . ,alist) (assq-ref alist <init>))))
162 ((<info> . ,alist) (assq-ref alist <locals>))))
164 (define (.function o)
166 ((<info> . ,alist) (assq-ref alist <function>))))
170 ((<info> . ,alist) (assq-ref alist <text>))))
174 ((<info> . ,alist) (assq-ref alist <break>))))
177 (and (pair? o) (eq? (car o) <info>)))
179 (define (clone o . rest)
181 (let ((types (.types o))
182 (constants (.constants o))
183 (functions (.functions o))
184 (globals (.globals o))
187 (function (.function o))
193 (constants constants)
194 (functions functions)
201 (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text #:break break))))))
203 (define (push-global globals)
206 `(lambda (f g ta t d)
207 (i386:push-global (+ (data-offset ,o g) d))))))
209 (define (push-local locals)
211 (wrap-as (i386:push-local (local:id o)))))
213 (define (push-global-address globals)
216 `(lambda (f g ta t d)
217 (i386:push-global-address (+ (data-offset ,o g) d))))))
219 (define (push-local-address locals)
221 (wrap-as (i386:push-local-address (local:id o)))))
223 (define push-global-de-ref push-global)
225 (define (push-local-de-ref info)
228 (ptr (local:pointer local))
229 (size (if (= ptr 1) (type->size info (local:type o))
232 (wrap-as (i386:push-byte-local-de-ref (local:id o)))
233 (wrap-as (i386:push-local-de-ref (local:id o)))))))
236 (define (push-local-de-de-ref info)
239 (ptr (local:pointer local))
240 (size (if (= ptr 2) (type->size info (local:type o));; URG
243 (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
244 (error "TODO int-de-de-ref")))))
246 (define (string->global string)
247 (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
249 (define (int->global value)
250 (make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value)))
252 (define (ident->global name type pointer value)
253 (make-global name type pointer (int->bv32 value)))
255 (define (make-local name type pointer id)
256 (cons name (list type pointer id)))
257 (define local:type car)
258 (define local:pointer cadr)
259 (define local:id caddr)
261 (define (push-ident info)
263 (let ((local (assoc-ref (.locals info) o)))
266 (let* ((ptr (local:pointer local))
267 (size (if (= ptr 1) (type->size info (local:type local))
269 (if (= ptr -1) ((push-local-address (.locals info)) local)
270 ((push-local (.locals info)) local))))
271 (let ((global (assoc-ref (.globals info) o)))
273 ((push-global (.globals info)) o) ;; FIXME: char*/int
274 (let ((constant (assoc-ref (.constants info) o)))
276 (wrap-as (append (i386:value->accu constant)
278 (error "TODO:push-function: " o)))))))))
280 (define (push-ident-address info)
282 (let ((local (assoc-ref (.locals info) o)))
283 (if local ((push-local-address (.locals info)) local)
284 ((push-global-address (.globals info)) o)))))
286 (define (push-ident-de-ref info)
288 (let ((local (assoc-ref (.locals info) o)))
289 (if local ((push-local-de-ref info) local)
290 ((push-global-de-ref (.globals info)) o)))))
292 (define (push-ident-de-de-ref info)
294 (let ((local (assoc-ref (.locals info) o)))
295 (if local ((push-local-de-de-ref info) local)
296 (error "TODO: global push-local-de-de-ref")))))
298 (define (expr->arg info)
300 (let ((info ((expr->accu info) o)))
301 (append-text info (wrap-as (i386:push-accu))))))
303 (define (globals:add-string globals)
305 (let ((string (add-s:-prefix o)))
306 (if (assoc-ref globals string) globals
307 (append globals (list (string->global o)))))))
309 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
311 (let ((text (.text info)))
314 ((p-expr (string ,string))
315 (let* ((globals ((globals:add-string (.globals info)) string))
316 (info (clone info #:globals globals)))
317 (append-text info ((push-global-address info) (add-s:-prefix string)))))
319 ((p-expr (ident ,name))
320 (append-text info ((push-ident info) name)))
322 ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
323 (abs-declr (pointer)))
325 ((expr->arg info) cast))
327 ((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast)
328 ((expr->arg info) cast))
330 ((de-ref (p-expr (ident ,name)))
331 (append-text info ((push-ident-de-ref info) name)))
333 ((de-ref (de-ref (p-expr (ident ,name))))
334 (append-text info ((push-ident-de-de-ref info) name)))
336 ((ref-to (p-expr (ident ,name)))
337 (append-text info ((push-ident-address info) name)))
339 (_ (append-text ((expr->accu info) o)
340 (wrap-as (i386:push-accu))))))))
342 ;; FIXME: see ident->base
343 (define (ident->accu info)
345 (let ((local (assoc-ref (.locals info) o))
346 (global (assoc-ref (.globals info) o))
347 (constant (assoc-ref (.constants info) o)))
349 (let* ((ptr (local:pointer local))
350 (type (ident->type info o))
351 (size (if (= ptr 0) (type->size info type)
354 ((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
355 ((1) (wrap-as (i386:local->accu (local:id local))))
357 (wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
358 (i386:local->accu (local:id local)))))))
360 (let* ((ptr (ident->pointer info o))
361 (type (ident->type info o))
362 (size (if (= ptr 1) (type->size info type)
365 ((-1) (list `(lambda (f g ta t d)
366 (i386:global->accu (+ (data-offset ,o g) d)))))
367 ((1) (list `(lambda (f g ta t d)
368 (i386:global-address->accu (+ (data-offset ,o g) d)))))
370 ((2) (list `(lambda (f g ta t d)
371 (append (i386:value->accu (+ (data-offset ,o g) d))))))
372 (else (list `(lambda (f g ta t d)
373 (i386:global-address->accu (+ (data-offset ,o g) d)))))))
374 (if constant (wrap-as (i386:value->accu constant))
375 (list `(lambda (f g ta t d)
376 (i386:global->accu (+ ta (function-offset ,o f)))))))))))
378 (define (ident-address->accu info)
380 (let ((local (assoc-ref (.locals info) o))
381 (global (assoc-ref (.globals info) o))
382 (constant (assoc-ref (.constants info) o)))
384 (let* ((ptr (local:pointer local))
385 (type (ident->type info o))
386 (size (if (= ptr 1) (type->size info type)
388 ;;(stderr "ident->accu ~a => ~a\n" o ptr)
389 (wrap-as (i386:local-ptr->accu (local:id local))))
391 (let ((ptr (ident->pointer info o)))
394 ;; (list `(lambda (f g ta t d)
395 ;; (i386:global->accu (+ (data-offset ,o g) d)))))
396 (else (list `(lambda (f g ta t d)
397 (append (i386:value->accu (+ (data-offset ,o g) d))))))))
398 (list `(lambda (f g ta t d)
399 (i386:global->accu (+ ta (function-offset ,o f))))))))))
401 (define (ident-address->base info)
403 (let ((local (assoc-ref (.locals info) o))
404 (global (assoc-ref (.globals info) o))
405 (constant (assoc-ref (.constants info) o)))
407 (let* ((ptr (local:pointer local))
408 (type (ident->type info o))
409 (size (if (= ptr 1) (type->size info type)
411 (wrap-as (i386:local-ptr->base (local:id local))))
413 (let ((ptr (ident->pointer info o)))
416 (list `(lambda (f g ta t d)
417 (i386:global->base (+ (data-offset ,o g) d)))))
418 (else (list `(lambda (f g ta t d)
419 (append (i386:value->base (+ (data-offset ,o g) d))))))))
420 (error "TODO ident-address->base" o))))))
422 (define (value->accu v)
423 (wrap-as (i386:value->accu v)))
425 (define (accu->ident info)
427 (let ((local (assoc-ref (.locals info) o)))
429 (let ((ptr (local:pointer local)))
431 (else (wrap-as (i386:accu->local (local:id local))))))
432 (let ((ptr (ident->pointer info o)))
433 (list `(lambda (f g ta t d)
434 (i386:accu->global (+ (data-offset ,o g) d)))))))))
436 (define (base->ident info)
438 (let ((local (assoc-ref (.locals info) o)))
439 (if local (wrap-as (i386:base->local (local:id local)))
440 (list `(lambda (f g ta t d)
441 (i386:base->global (+ (data-offset ,o g) d))))))))
443 (define (base->ident-address info)
445 (let ((local (assoc-ref (.locals info) o)))
447 (let* ((ptr (local:pointer local))
448 (type (ident->type info o))
449 (size (if (= ptr 1) (type->size info type)
451 (wrap-as (append (i386:local->accu (local:id local))
452 (if (= size 1) (i386:byte-base->accu-address)
453 (i386:byte-base->accu-address)))))
454 (error "TODO:base->ident-address-global" o)))))
456 (define (value->ident info)
458 (let ((local (assoc-ref (.locals info) o)))
459 (if local (wrap-as (i386:value->local (local:id local) value))
460 (list `(lambda (f g ta t d)
461 (i386:value->global (+ (data-offset ,o g) d) value)))))))
463 (define (ident-add info)
465 (let ((local (assoc-ref (.locals info) o)))
466 (if local (wrap-as (i386:local-add (local:id local) n))
467 (list `(lambda (f g ta t d)
468 (i386:global-add (+ (data-offset ,o g) d) ,n)))))))
470 (define (ident-address-add info)
472 (let ((local (assoc-ref (.locals info) o)))
473 (if local (wrap-as (append (i386:push-accu)
474 (i386:local->accu (local:id local))
475 (i386:accu-mem-add n)
477 (list `(lambda (f g ta t d)
478 (append (i386:push-accu)
479 (i386:global->accu (+ (data-offset ,o g) d))
480 (i386:accu-mem-add ,n)
481 (i386:pop-accu))))))))
483 ;; FIXME: see ident->accu
484 (define (ident->base info)
486 (let ((local (assoc-ref (.locals info) o)))
488 (let* ((ptr (local:pointer local))
489 (type (ident->type info o))
490 (size (if (and type (= ptr 1)) (type->size info type)
493 ((-1) (wrap-as (i386:local-ptr->base (local:id local))))
494 ((1) (wrap-as (i386:local->base (local:id local))))
496 (wrap-as (if (= size 1) (i386:byte-local->base (local:id local))
497 (i386:local->base (local:id local)))))))
498 (let ((global (assoc-ref (.globals info) o) ))
500 (let ((ptr (ident->pointer info o)))
502 ((-1) (list `(lambda (f g ta t d)
503 (i386:global->base (+ (data-offset ,o g) d)))))
504 ((2) (list `(lambda (f g ta t d)
505 (i386:global->base (+ (data-offset ,o g) d)))))
506 (else (list `(lambda (f g ta t d)
507 (i386:global-address->base (+ (data-offset ,o g) d)))))))
508 (let ((constant (assoc-ref (.constants info) o)))
509 (if constant (wrap-as (i386:value->base constant))
510 (list `(lambda (f g ta t d)
511 (i386:global->base (+ ta (function-offset ,o f)))))))))))))
513 (define (expr->accu info)
515 (let ((locals (.locals info))
516 (constants (.constants info))
518 (globals (.globals info)))
519 (define (add-local locals name type pointer)
520 (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
521 (1+ (local:id (cdar locals)))))
522 (locals (cons (make-local name type pointer id) locals)))
526 ((p-expr (string ,string))
527 (let* ((globals (append globals (list (string->global string))))
528 (info (clone info #:globals globals)))
529 (append-text info (list `(lambda (f g ta t d)
530 (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))))
532 ((p-expr (string . ,strings))
533 (append-text info (list `(lambda (f g ta t d)
534 (i386:global->accu (+ (data-offset ,(add-s:-prefix (apply string-append strings)) g) d))))))
535 ((p-expr (fixed ,value))
536 (append-text info (value->accu (cstring->number value))))
538 ((p-expr (ident ,name))
539 (append-text info ((ident->accu info) name)))
541 ((initzer ,initzer) ((expr->accu info) initzer))
544 ((ref-to (p-expr (ident ,name)))
545 (append-text info ((ident-address->accu info) name)))
548 ((ref-to (d-sel (ident ,field) (p-expr (ident ,array))))
549 (let* ((type (ident->type info array))
550 (fields (type->description info type))
551 (field-size 4) ;; FIXME:4, not fixed
552 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
554 (append-text info (append ((ident->accu info) array)
555 (wrap-as (i386:accu+n offset))))))
558 ((ref-to (array-ref ,index (p-expr (ident ,array))))
559 ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
561 ((sizeof-expr (p-expr (ident ,name)))
562 (let* ((type (ident->type info name))
563 (fields (or (type->description info type) '()))
564 (size (type->size info type)))
565 (append-text info (wrap-as (i386:value->accu size)))))
567 ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name)))))
569 (fields (or (type->description info type) '()))
570 (size (type->size info type)))
571 (append-text info (wrap-as (i386:value->accu size)))))
573 ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
574 (let* ((type (list "struct" name))
575 (fields (or (type->description info type) '()))
576 (size (type->size info type)))
577 (append-text info (wrap-as (i386:value->accu size)))))
581 ((array-ref ,index (p-expr (ident ,array)))
582 (let* ((type (ident->type info array))
583 (ptr (ident->pointer info array))
584 (size (if (< ptr 2) (type->size info type)
586 (info ((expr->accu* info) o)))
587 (append-text info (wrap-as (append (case size
588 ((1) (i386:byte-mem->accu))
589 ((4) (i386:mem->accu))
593 ((d-sel (ident ,field) (p-expr (ident ,array)))
594 (let* ((type (ident->type info array))
595 (fields (type->description info type))
596 (field-size 4) ;; FIXME:4, not fixed
597 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
599 (append-text info (append ((ident->accu info) array)
600 (wrap-as (i386:mem+n->accu offset))))))
602 ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
603 (let* ((type (ident->type info array))
604 (fields (or (type->description info type) '()))
605 (field-size 4) ;; FIXME:4, not fixed
606 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
608 (stderr "no field:~a\n" field)
610 (offset (* field-size (1- (length rest))))
611 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
612 (append-text info (wrap-as (i386:mem+n->accu offset)))))
614 ((i-sel (ident ,field) (p-expr (ident ,array)))
615 (let* ((type (ident->type info array))
616 (fields (type->description info type))
617 (field-size 4) ;; FIXME:4, not fixed
618 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
620 (append-text info (append ((ident-address->accu info) array)
621 (wrap-as (i386:mem->accu))
622 (wrap-as (i386:mem+n->accu offset))))))
624 ;;; FIXME: FROM INFO ...only zero?!
625 ((p-expr (fixed ,value))
626 (let ((value (cstring->number value)))
627 (append-text info (wrap-as (i386:value->accu value)))))
629 ((p-expr (char ,char))
630 (let ((char (char->integer (car (string->list char)))))
631 (append-text info (wrap-as (i386:value->accu char)))))
633 ((p-expr (ident ,name))
634 (append-text info ((ident->accu info) name)))
636 ((de-ref (p-expr (ident ,name)))
637 (let* ((type (ident->type info name))
638 (ptr (ident->pointer info name))
639 (size (if (= ptr 1) (type->size info type)
641 (append-text info (append ((ident->accu info) name)
642 (wrap-as (if (= size 1) (i386:byte-mem->accu)
643 (i386:mem->accu)))))))
645 ((de-ref (post-inc (p-expr (ident ,name))))
646 (let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
647 (type (ident->type info name))
648 (ptr (ident->pointer info name))
649 (size (if (= ptr 1) (type->size info type)
651 (append-text info ((ident-add info) name size))))
654 (let ((info ((expr->accu info) expr)))
655 (append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
657 ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
658 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
659 (append-text info (wrap-as (asm->hex arg0))))
660 (let* ((text-length (length text))
661 (args-info (let loop ((expressions (reverse expr-list)) (info info))
662 (if (null? expressions) info
663 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
664 (n (length expr-list)))
665 (if (and (not (assoc-ref locals name))
666 (assoc name (.functions info)))
667 (append-text args-info (list `(lambda (f g ta t d)
668 (i386:call f g ta t d (+ t (function-offset ,name f)) ,n))))
669 (let* ((empty (clone info #:text '()))
670 (accu ((expr->accu empty) `(p-expr (ident ,name)))))
671 (append-text args-info (append (.text accu)
672 (list `(lambda (f g ta t d)
673 (i386:call-accu f g ta t d ,n))))))))))
675 ((fctn-call ,function (expr-list . ,expr-list))
676 (let* ((text-length (length text))
677 (args-info (let loop ((expressions (reverse expr-list)) (info info))
678 (if (null? expressions) info
679 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
680 (n (length expr-list))
681 (empty (clone info #:text '()))
682 (accu ((expr->accu empty) function)))
683 (append-text args-info (append (.text accu)
684 (list `(lambda (f g ta t d)
685 (i386:call-accu f g ta t d ,n)))))))
687 ((cond-expr . ,cond-expr)
688 ((ast->info info) `(expr-stmt ,o)))
690 ((post-inc (p-expr (ident ,name)))
691 (let* ((type (ident->type info name))
692 (ptr (ident->pointer info name))
693 (size (if (> ptr 1) 4 1)))
694 (append-text info (append ((ident->accu info) name)
695 ((ident-add info) name size)))))
697 ((post-dec (p-expr (ident ,name)))
698 (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
699 (append-text info (append ((ident->accu info) name)
700 ((ident-add info) name -1))))
702 ((pre-inc (p-expr (ident ,name)))
703 (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) (error "undefined identifier: " name)))
704 (append-text info (append ((ident-add info) name 1)
705 ((ident->accu info) name))))
707 ((pre-dec (p-expr (ident ,name)))
708 (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) (error "undefined identifier: " name)))
709 (append-text info (append ((ident-add info) name -1)
710 ((ident->accu info) name))))
712 ((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
713 ((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
714 ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
715 ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
716 ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
717 ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
718 ((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
719 ((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
720 ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
721 ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
724 (let* ((test-info ((ast->info info) expr)))
726 (append (.text test-info)
727 (wrap-as (i386:accu-not)))
728 #:globals (.globals test-info))))
730 ((neg (p-expr (fixed ,value)))
731 (append-text info (value->accu (- (cstring->number value)))))
733 ((neg (p-expr (ident ,name)))
734 (append-text info (append ((ident->base info) name)
735 (wrap-as (i386:value->accu 0))
736 (wrap-as (i386:sub-base)))))
738 ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
739 ((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
740 ((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
742 ;; FIXME: set accu *and* flags
743 ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
751 ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
752 ((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
753 ((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
756 (let* ((empty (clone info #:text '()))
757 (b-length (length (append (i386:Xjump-nz 0)
759 (info ((expr->accu info) a))
760 (info (append-text info (wrap-as (i386:accu-test))))
761 (info (append-text info (wrap-as (append (i386:Xjump-nz (- b-length 1))
763 (info ((expr->accu info) b))
764 (info (append-text info (wrap-as (i386:accu-test)))))
768 (let* ((empty (clone info #:text '()))
769 (b-length (length (append (i386:Xjump-z 0)
771 (info ((expr->accu info) a))
772 (info (append-text info (wrap-as (i386:accu-test))))
773 (info (append-text info (wrap-as (append (i386:Xjump-z (- b-length 1))
775 (info ((expr->accu info) b))
776 (info (append-text info (wrap-as (i386:accu-test)))))
780 ((expr->accu info) o))
782 ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
783 (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
784 (append-text info ((ident-add info) name 1)))) ;; FIXME: size
786 ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
787 (let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
788 (append-text info ((ident-add info) name -1)))) ;; FIXME: size
790 ((assn-expr ,a (op ,op) ,b)
791 (let* ((info ((expr->accu info) b))
792 (info (if (equal? op "=") info
793 (let* ((info (append-text info (wrap-as (i386:push-accu))))
794 (info ((expr->accu info) a))
795 (info (append-text info (wrap-as (i386:pop-base)))))
796 (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
797 ((equal? op "-=") (wrap-as (i386:accu-base)))
798 ((equal? op "*=") (wrap-as (i386:accu*base)))
799 ((equal? op "/=") (wrap-as (i386:accu/base)))
800 ((equal? op "%=") (wrap-as (i386:accu%base)))
801 ((equal? op "|=") (wrap-as (i386:accu-or-base)))
802 (else (error "mescc: op ~a not supported: ~a\n" op o))))))))
804 ((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
805 ((d-sel (ident ,field) ,p-expr)
806 (let* ((type (p-expr->type info p-expr))
807 (fields (type->description info type))
808 (size (type->size info type))
809 (field-size 4) ;; FIXME:4, not fixed
810 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
811 (info (append-text info (wrap-as (i386:push-accu))))
812 (info ((expr->accu* info) a))
813 (info (append-text info (wrap-as (i386:pop-base)))))
814 (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
816 ((de-ref (p-expr (ident ,array)))
817 (let* ((type (ident->type info array))
818 (ptr (ident->pointer info array))
819 (size (if (> ptr 1) 4 1)))
820 (append-text info (append (wrap-as (i386:accu->base))
821 ((base->ident-address info) array)
822 (i386:base->accu)))))
823 ((array-ref ,index (p-expr (ident ,array)))
824 (let* ((type (ident->type info array))
825 (size (type->size info type))
826 (info (append-text info (wrap-as (append (i386:push-accu)))))
827 (info ((expr->accu* info) a))
828 (info (append-text info (wrap-as (append (i386:pop-base))))))
830 (append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
831 (if (<= size 4) (wrap-as (i386:base->accu-address))
833 (wrap-as (i386:base-address->accu-address))
834 (wrap-as (append (i386:accu+n 4)
836 (i386:base-address->accu-address)))
838 (wrap-as (append (i386:accu+n 4)
840 (i386:base-address->accu-address)))))))))))
841 (_ (error "expr->accu: unsupported assign: " a)))))
843 (_ (error "expr->accu: unsupported: " o))))))
845 (define (expr->base info)
847 (let* ((info (append-text info (wrap-as (i386:push-accu))))
848 (info ((expr->accu info) o))
849 (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
852 (define (binop->accu info)
854 (let* ((info ((expr->accu info) a))
855 (info ((expr->base info) b)))
856 (append-text info (wrap-as c)))))
858 (define (append-text info text)
859 (clone info #:text (append (.text info) text)))
862 (list `(lambda (f g ta t d) ,(cons 'list o))))
864 (define (expr->accu* info)
868 ((array-ref ,index (p-expr (ident ,array)))
869 (let* ((info ((expr->accu info) index))
870 (type (ident->type info array))
871 (ptr (ident->pointer info array))
872 (size (if (< ptr 2) (type->size info type)
874 (append-text info (append (wrap-as (append (i386:accu->base)
881 (i386:accu-shl 2)))))
882 ((ident->base info) array)
883 (wrap-as (i386:accu+base))))))
885 ;; g_cells[<expr>].type
886 ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
887 (let* ((type (ident->type info array))
888 (fields (or (type->description info type) '()))
889 (field-size 4) ;; FIXME:4, not fixed
890 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
891 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
892 (append-text info (wrap-as (append (i386:accu+value offset))))))
894 ((d-sel (ident ,field) (p-expr (ident ,name)))
895 (let* ((type (ident->type info name))
896 (fields (or (type->description info type) '()))
897 (field-size 4) ;; FIXME
898 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
900 (append-text info (append ((ident->accu info) name)
901 (wrap-as (i386:accu+value offset))))))
903 (_ (error "expr->accu*: unsupported: " o)))))
905 (define (ident->constant name value)
908 (define (make-type name type size description)
909 (cons name (list type size description)))
911 (define (enum->type name fields)
912 (make-type name 'enum 4 fields))
914 (define (struct->type name fields)
915 (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
917 (define (decl->type o)
919 ((fixed-type ,type) type)
920 ((struct-ref (ident ,name)) (list "struct" name))
921 ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
922 (list "struct" name)) ;; FIXME
923 ((typename ,name) name)
925 (_ (error "decl->type: unsupported: " o))))
927 (define (expr->global o)
929 ((p-expr (string ,string)) (string->global string))
930 ((p-expr (fixed ,value)) (int->global (cstring->number value)))
933 (define (initzer->global o)
935 ((initzer ,initzer) (expr->global initzer))
938 (define (byte->hex o)
939 (string->number (string-drop o 2) 16))
942 (let ((prefix ".byte "))
943 (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
944 (let ((s (string-drop o (string-length prefix))))
945 (map byte->hex (string-split s #\space))))))
947 (define (clause->jump-info info)
949 (wrap-as (i386:Xjump n)))
951 (wrap-as (i386:Xjump-nz n)))
953 (wrap-as (i386:Xjump-z n)))
954 (define (statement->info info body-length)
957 ((break) (append-text info (jump body-length)))
958 (_ ((ast->info info) o)))))
959 (define (test->text test)
960 (let ((value (pmatch test
962 ((p-expr (char ,value)) (char->integer (car (string->list value))))
963 ((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
964 ((p-expr (fixed ,value)) (cstring->number value))
965 ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
966 (_ (error "case test: unsupported: " test)))))
968 (append (wrap-as (i386:accu-cmp-value value))
969 (jump-z (+ (length (object->list (jump 0)))
971 (* n (length (object->list ((test->text 0) 0)))))))))))
972 (define (cases+jump cases clause-length)
975 (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
976 (if (null? cases) '()
977 (jump clause-length)))))
979 (lambda (body-length)
980 (let loop ((o o) (cases '()) (clause #f))
982 ((case ,test ,statement)
983 (loop statement (append cases (list (test->text test))) clause))
984 ((default ,statement)
985 (loop statement cases clause))
986 ((compd-stmt (block-item-list))
987 (loop '() cases clause))
988 ((compd-stmt (block-item-list . ,elements))
989 (let ((clause (or clause (cases+jump cases 0))))
990 (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
991 ((statement->info clause body-length) (car elements)))))
993 (let* ((cases-length (length (.text (cases+jump cases 0))))
994 (clause-text (list-tail (.text clause) cases-length))
995 (clause-length (length (object->list clause-text))))
997 (append (.text (cases+jump cases clause-length))
1000 (let ((clause (or clause (cases+jump cases 0))))
1002 ((statement->info clause body-length) o)))))))))
1004 (define (test->jump->info info)
1005 (define (jump type . test)
1007 (let* ((text (.text info))
1008 (info (clone info #:text '()))
1009 (info ((ast->info info) o))
1010 (jump-text (lambda (body-length)
1011 (wrap-as (type body-length)))))
1012 (lambda (body-length)
1016 (if (null? test) '() (car test))
1017 (jump-text body-length)))))))
1021 ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1022 ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o)) ; jae
1023 ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1024 ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1026 ((le ,a ,b) ((jump i386:Xjump-g) o))
1027 ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1028 ((ge ,a ,b) ((jump i386:Xjump-g) o))
1029 ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1031 ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1032 ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1033 ((not _) ((jump i386:Xjump-z) o))
1035 (let* ((globals (.globals info))
1037 (info (clone info #:text '()))
1039 (a-jump ((test->jump->info info) a))
1040 (a-text (.text (a-jump 0)))
1041 (a-length (length (object->list a-text)))
1043 (b-jump ((test->jump->info info) b))
1044 (b-text (.text (b-jump 0)))
1045 (b-length (length (object->list b-text))))
1047 (lambda (body-length)
1048 (let* ((info (append-text info text))
1049 (a-info (a-jump (+ b-length body-length)))
1050 (info (append-text info (.text a-info)))
1051 (b-info (b-jump body-length))
1052 (info (append-text info (.text b-info))))
1054 #:globals (append globals
1055 (list-tail (.globals a-info) (length globals))
1056 (list-tail (.globals b-info) (length globals))))))))
1059 (let* ((globals (.globals info))
1061 (info (clone info #:text '()))
1063 (a-jump ((test->jump->info info) a))
1064 (a-text (.text (a-jump 0)))
1065 (a-length (length (object->list a-text)))
1067 (jump-text (wrap-as (i386:Xjump 0)))
1068 (jump-length (length (object->list jump-text)))
1070 (b-jump ((test->jump->info info) b))
1071 (b-text (.text (b-jump 0)))
1072 (b-length (length (object->list b-text)))
1074 (jump-text (wrap-as (i386:Xjump b-length))))
1076 (lambda (body-length)
1077 (let* ((info (append-text info text))
1078 (a-info (a-jump jump-length))
1079 (info (append-text info (.text a-info)))
1080 (info (append-text info jump-text))
1081 (b-info (b-jump body-length))
1082 (info (append-text info (.text b-info))))
1084 #:globals (append globals
1085 (list-tail (.globals a-info) (length globals))
1086 (list-tail (.globals b-info) (length globals))))))))
1088 ((array-ref . _) ((jump i386:jump-byte-z
1089 (wrap-as (i386:accu-zero?))) o))
1091 ((de-ref _) ((jump i386:jump-byte-z
1092 (wrap-as (i386:accu-zero?))) o))
1094 ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1097 ((ident->accu info) name)
1098 (wrap-as (i386:accu-zero?)))) o))
1100 (_ ((jump i386:Xjump-z (wrap-as (i386:accu-zero?))) o)))))
1102 (define (cstring->number s)
1103 (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1104 ((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
1105 ((string-prefix? "0" s) (string->number s 8))
1106 (else (string->number s))))
1108 (define (struct-field o)
1110 ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1111 (comp-declr-list (comp-declr (ident ,name))))
1113 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1115 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1117 ((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-decl (decl-spec-list (type-spec (void)))))))))
1118 (cons type name)) ;; FIXME function / int
1119 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1120 (cons type name)) ;; FIXME: ptr/char
1121 (_ (error "struct-field: unsupported: " o))))
1123 (define (ast->type o)
1127 ((struct-ref (ident ,type))
1128 (list "struct" type))
1129 (_ (stderr "SKIP: type=~s\n" o)
1132 (define i386:type-alist
1133 '(("char" . (builtin 1 #f))
1134 ("short" . (builtin 2 #f))
1135 ("int" . (builtin 4 #f))))
1137 (define (type->size info o)
1139 ((decl-spec-list (type-spec (fixed-type ,type)))
1140 (type->size info type))
1141 ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1142 (type->size info type))
1143 (_ (let ((type (assoc-ref (.types info) o)))
1144 (if type (cadr type)
1145 (error "type->size: unsupported: " o))))))
1147 (define (ident->decl info o)
1148 (or (assoc-ref (.locals info) o)
1149 (assoc-ref (.globals info) o)
1151 (stderr "NO IDENT: ~a\n" o)
1152 (assoc-ref (.functions info) o))))
1154 (define (ident->type info o)
1155 (and=> (ident->decl info o) car))
1157 (define (ident->pointer info o)
1158 (let ((local (assoc-ref (.locals info) o)))
1159 (if local (local:pointer local)
1160 (or (and=> (ident->decl info o) global:pointer) 0))))
1162 (define (p-expr->type info o)
1164 ((p-expr (ident ,name)) (ident->type info name))
1165 ((array-ref ,index (p-expr (ident ,array)))
1166 (ident->type info array))
1167 (_ (error "p-expr->type: unsupported: " o))))
1169 (define (type->description info o)
1171 ((decl-spec-list (type-spec (fixed-type ,type)))
1172 (type->description info type))
1173 ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1174 (type->description info type))
1175 (_ (let ((type (assoc-ref (.types info) o)))
1176 (if (not type) (stderr "TYPES=~s\n" (.types info)))
1177 (if type (caddr type)
1178 (error "type->description: unsupported:" o))))))
1180 (define (local? o) ;; formals < 0, locals > 0
1181 (positive? (local:id o)))
1183 (define (statements->clauses statements)
1184 (let loop ((statements statements) (clauses '()))
1185 (if (null? statements) clauses
1186 (let ((s (car statements)))
1188 ((case ,test (compd-stmt (block-item-list . _)))
1189 (loop (cdr statements) (append clauses (list s))))
1190 ((case ,test (break))
1191 (loop (cdr statements) (append clauses (list s))))
1192 ((case ,test) (loop (cdr statements) (append clauses (list s))))
1194 ((case ,test ,statement)
1195 (let loop2 ((statement statement) (heads `((case ,test))))
1196 (define (heads->case heads statement)
1197 (if (null? heads) statement
1198 (append (car heads) (list (heads->case (cdr heads) statement)))))
1200 ((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
1201 ((default ,s2) (loop2 s2 (append heads `((default)))))
1202 ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
1203 (_ (let loop3 ((statements (cdr statements)) (c (list statement)))
1204 (if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
1205 (let ((s (car statements)))
1207 ((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1208 ((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
1209 ((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
1210 (_ (loop3 (cdr statements) (append c (list s))))))))))))
1211 ((default (compd-stmt (block-item-list _)))
1212 (loop (cdr statements) (append clauses (list s))))
1213 ((default . ,statement)
1214 (let loop2 ((statements (cdr statements)) (c statement))
1215 (if (null? statements) (loop statements (append clauses (list `(default ,@c))))
1216 (let ((s (car statements)))
1218 ((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
1219 ((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1220 ((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
1221 ((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
1223 (_ (loop2 (cdr statements) (append c (list s)))))))))
1224 (_ (error "statements->clauses: unsupported:" s)))))))
1226 (define (ast->info info)
1228 (let ((functions (.functions info))
1229 (globals (.globals info))
1230 (locals (.locals info))
1231 (constants (.constants info))
1232 (text (.text info)))
1233 (define (add-local locals name type pointer)
1234 (let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
1235 (1+ (local:id (cdar locals)))))
1236 (locals (cons (make-local name type pointer id) locals)))
1238 (define (declare name)
1239 (if (member name functions) info
1240 (clone info #:functions (cons (cons name #f) functions))))
1242 (((trans-unit . _) . _)
1243 ((ast-list->info info) o))
1244 ((trans-unit . ,elements)
1245 ((ast-list->info info) elements))
1246 ((fctn-defn . _) ((function->info info) o))
1247 ((comment . _) info)
1248 ((cpp-stmt (define (name ,name) (repl ,value)))
1251 ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1255 (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text)))))))
1257 ;; FIXME: expr-stmt wrapper?
1261 ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1263 ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1264 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
1265 (append-text info (wrap-as (asm->hex arg0))))
1266 (let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
1267 (append-text info (wrap-as (i386:accu-zero?))))))
1270 (let* ((text-length (length text))
1272 (test-jump->info ((test->jump->info info) test))
1273 (test+jump-info (test-jump->info 0))
1274 (test-length (length (.text test+jump-info)))
1276 (body-info ((ast->info test+jump-info) body))
1277 (text-body-info (.text body-info))
1278 (body-text (list-tail text-body-info test-length))
1279 (body-length (length (object->list body-text)))
1281 (text+test-text (.text (test-jump->info body-length)))
1282 (test-text (list-tail text+test-text text-length)))
1288 #:globals (.globals body-info))))
1290 ((if ,test ,then ,else)
1291 (let* ((text-length (length text))
1293 (test-jump->info ((test->jump->info info) test))
1294 (test+jump-info (test-jump->info 0))
1295 (test-length (length (.text test+jump-info)))
1297 (then-info ((ast->info test+jump-info) then))
1298 (text-then-info (.text then-info))
1299 (then-text (list-tail text-then-info test-length))
1300 (then-jump-text (wrap-as (i386:Xjump 0)))
1301 (then-jump-length (length (object->list then-jump-text)))
1302 (then-length (+ (length (object->list then-text)) then-jump-length))
1304 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1305 (else-info ((ast->info then+jump-info) else))
1306 (text-else-info (.text else-info))
1307 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1308 (else-length (length (object->list else-text)))
1310 (text+test-text (.text (test-jump->info then-length)))
1311 (test-text (list-tail text+test-text text-length))
1312 (then-jump-text (wrap-as (i386:Xjump else-length))))
1320 #:globals (append (.globals then-info)
1321 (list-tail (.globals else-info) (length globals))))))
1324 ((expr-stmt (cond-expr ,test ,then ,else))
1325 (let* ((text-length (length text))
1327 (test-jump->info ((test->jump->info info) test))
1328 (test+jump-info (test-jump->info 0))
1329 (test-length (length (.text test+jump-info)))
1331 (then-info ((ast->info test+jump-info) then))
1332 (text-then-info (.text then-info))
1333 (then-text (list-tail text-then-info test-length))
1334 (then-length (length (object->list then-text)))
1336 (jump-text (wrap-as (i386:Xjump 0)))
1337 (jump-length (length (object->list jump-text)))
1339 (test+then+jump-info
1341 #:text (append (.text then-info) jump-text)))
1343 (else-info ((ast->info test+then+jump-info) else))
1344 (text-else-info (.text else-info))
1345 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1346 (else-length (length (object->list else-text)))
1348 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1349 (test-text (list-tail text+test-text text-length))
1350 (jump-text (wrap-as (i386:Xjump else-length))))
1358 #:globals (.globals else-info))))
1360 ((switch ,expr (compd-stmt (block-item-list . ,statements)))
1361 (let* ((clauses (statements->clauses statements))
1362 (expr ((expr->accu info) expr))
1363 (empty (clone info #:text '()))
1364 (clause-infos (map (clause->jump-info empty) clauses))
1365 (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
1366 (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
1367 (if (null? clauses) info
1368 (let ((c-j ((clause->jump-info info) (car clauses))))
1369 (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1372 ((for ,init ,test ,step ,body)
1373 (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1375 (info ((ast->info info) init))
1377 (init-text (.text info))
1378 (init-locals (.locals info))
1379 (info (clone info #:text '()))
1381 (body-info ((ast->info info) body))
1382 (body-text (.text body-info))
1383 (body-length (length (object->list body-text)))
1385 (step-info ((expr->accu info) step))
1386 (step-text (.text step-info))
1387 (step-length (length (object->list step-text)))
1389 (test-jump->info ((test->jump->info info) test))
1390 (test+jump-info (test-jump->info 0))
1391 (test-length (length (object->list (.text test+jump-info))))
1393 (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
1395 (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
1396 (jump-length (length (object->list jump-text)))
1398 (test-text (.text (test-jump->info jump-length))))
1408 #:globals (append globals (list-tail (.globals body-info) (length globals)))
1411 ((while ,test ,body)
1412 (let* ((skip-info (lambda (body-length test-length)
1414 #:text (append text (wrap-as (i386:Xjump body-length)))
1415 #:break (cons (+ (length (object->list text)) body-length test-length
1416 (length (i386:Xjump 0)))
1418 (text (.text (skip-info 0 0)))
1419 (text-length (length text))
1420 (body-info (lambda (body-length test-length)
1421 ((ast->info (skip-info body-length test-length)) body)))
1423 (body-text (list-tail (.text (body-info 0 0)) text-length))
1424 (body-length (length (object->list body-text)))
1426 (empty (clone info #:text '()))
1427 (test-jump->info ((test->jump->info empty) test))
1428 (test+jump-info (test-jump->info 0))
1429 (test-length (length (object->list (.text test+jump-info))))
1431 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1432 (jump-length (length (object->list jump-text)))
1434 (test-text (.text (test-jump->info jump-length)))
1436 (body-info (body-info body-length (length (object->list test-text)))))
1443 #:globals (.globals body-info))))
1445 ((do-while ,body ,test)
1446 (let* ((text-length (length text))
1448 (body-info ((ast->info info) body))
1449 (body-text (list-tail (.text body-info) text-length))
1450 (body-length (length (object->list body-text)))
1452 (empty (clone info #:text '()))
1453 (test-jump->info ((test->jump->info empty) test))
1454 (test+jump-info (test-jump->info 0))
1455 (test-length (length (object->list (.text test+jump-info))))
1457 (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
1458 (jump-length (length (object->list jump-text)))
1460 (test-text (.text (test-jump->info jump-length))))
1466 #:globals (.globals body-info))))
1468 ((labeled-stmt (ident ,label) ,statement)
1469 (let ((info (append-text info (list label))))
1470 ((ast->info info) statement)))
1472 ((goto (ident ,label))
1473 (let* ((jump (lambda (n) (i386:XXjump n)))
1474 (offset (+ (length (jump 0)) (length (object->list text)))))
1475 (append-text info (append
1476 (list `(lambda (f g ta t d)
1477 (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
1480 (let ((info ((expr->accu info) expr)))
1481 (append-text info (append (wrap-as (i386:ret))))))
1486 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1487 (if (.function info)
1488 (clone info #:locals (add-local locals name type 0))
1489 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1492 ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1493 (let ((type "int")) ;; FIXME
1494 (if (.function info)
1495 (clone info #:locals (add-local locals name type 0))
1496 (clone info #:globals (append globals (list (ident->global name type 0 0)))))))
1499 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1500 (let ((value (cstring->number value)))
1501 (if (.function info)
1502 (let* ((locals (add-local locals name type 0))
1503 (info (clone info #:locals locals)))
1504 (append-text info ((value->ident info) name value)))
1505 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1508 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1509 (if (not (.function info)) (error "ast->info: unsupported: " o))
1510 (let* ((locals (add-local locals name type 0))
1511 (info (clone info #:locals locals))
1512 (value (char->integer (car (string->list value)))))
1513 (append-text info ((value->ident info) name value))))
1516 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1517 (let ((value (- (cstring->number value))))
1518 (if (.function info)
1519 (let* ((locals (add-local locals name type 0))
1520 (info (clone info #:locals locals)))
1521 (append-text info ((value->ident info) name value)))
1522 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1525 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1526 (if (not (.function info)) (error "ast->info: unsupported: " o))
1527 (let* ((locals (add-local locals name type 0))
1528 (info (clone info #:locals locals)))
1529 (append-text info (append ((ident->accu info) local)
1530 ((accu->ident info) name)))))
1533 ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1534 (if (.function info)
1535 (let* ((locals (add-local locals name type 1))
1536 (globals (append globals (list (string->global string))))
1537 (info (clone info #:locals locals #:globals globals)))
1538 (append-text info (append
1539 (list `(lambda (f g ta t d)
1541 (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
1542 ((accu->ident info) name))))
1543 (let* ((global (string->global string))
1544 (globals (append globals (list global)))
1546 (global (make-global name type 1 (string->list (make-string size #\nul))))
1547 (globals (append globals (list global)))
1548 (info (clone info #:globals globals)))
1553 `(lambda (f g ta t d data)
1554 (let (((here (data-offset ,name g))))
1556 (list-head data here)
1557 (initzer->data f g ta t d '(initzer (p-expr (string ,string))))
1558 (list-tail data (+ here ,size)))))))))))
1561 ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1562 (if (.function info)
1563 (let* ((locals (add-local locals name type 1))
1564 (info (clone info #:locals locals)))
1565 (append-text info (append (wrap-as (i386:value->accu 0))
1566 ((accu->ident info) name))))
1567 (let ((globals (append globals (list (ident->global name type 1 0)))))
1568 (clone info #:globals globals))))
1571 ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
1572 (if (.function info)
1573 (let* ((locals (add-local locals name type 1))
1574 (info (clone info #:locals locals)))
1575 (append-text info (append (wrap-as (i386:value->accu 0))
1576 ((accu->ident info) name))))
1577 (let ((globals (append globals (list (ident->global name type 1 0)))))
1578 (clone info #:globals globals))))
1580 ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1581 (let ((value (cstring->number value)))
1582 (if (.function info)
1583 (let* ((locals (add-local locals name type 1))
1584 (info (clone info #:locals locals)))
1585 (append-text info (append (wrap-as (i386:value->accu value))
1586 ((accu->ident info) name))))
1587 (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
1590 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
1591 (if (.function info)
1592 (let* ((locals (add-local locals name type 2))
1593 (info (clone info #:locals locals)))
1594 (append-text info (append (wrap-as (i386:value->accu 0))
1595 ((accu->ident info) name))))
1596 (let ((globals (append globals (list (ident->global name type 2 0)))))
1597 (clone info #:globals globals))))
1600 ;;((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (fixed ,value)))))))
1602 ;; char **p = g_environment;
1603 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
1604 (if (.function info)
1605 (let* ((locals (add-local locals name type 2))
1606 (info (clone info #:locals locals)))
1607 (append-text info (append
1608 ((ident->accu info) b)
1609 ((accu->ident info) name))))
1610 (let* ((globals (append globals (list (ident->global name type 2 0))))
1611 (value (assoc-ref constants b)))
1614 #:init (append (.init info)
1616 `(lambda (f g ta t d data)
1617 (let ((here (data-offset ,name g)))
1619 (list-head data here)
1620 (initzer->data f g ta t d '(p-expr (fixed ,value)))
1621 (list-tail data (+ here 4)))))))))))
1623 ;; struct foo bar[2];
1624 ;; char arena[20000];
1625 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1626 (let ((type (ast->type type)))
1627 (if (.function info)
1628 (let* ((local (car (add-local locals name type -1)))
1629 (count (string->number count))
1630 (size (type->size info type))
1631 (local (make-local name type -1 (+ (local:id local) (* count size))))
1632 (locals (cons local locals))
1633 (info (clone info #:locals locals)))
1635 (let* ((globals (.globals info))
1636 (count (cstring->number count))
1637 (size (type->size info type))
1638 (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1639 (globals (append globals (list array))))
1640 (clone info #:globals globals)))))
1643 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
1644 (let ((type (ast->type type)))
1645 (if (.function info)
1646 (let* ((local (car (add-local locals name type -1)))
1647 (count (string->number count))
1648 (size (type->size info type))
1649 (local (make-local name type 1 (+ (local:id local) (* count size))))
1650 (locals (cons local locals))
1651 (info (clone info #:locals locals)))
1653 (let* ((globals (.globals info))
1654 (count (cstring->number count))
1655 (size (type->size info type))
1656 (array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
1657 (globals (append globals (list array))))
1658 (clone info #:globals globals)))))
1661 ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
1662 (if (.function info)
1663 (let* ((locals (add-local locals name `("struct" ,type) 1))
1664 (info (clone info #:locals locals)))
1666 (let* ((size (type->size info (list "struct" type)))
1667 (global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
1668 (globals (append globals (list global)))
1669 (info (clone info #:globals globals)))
1672 ;;struct scm *g_cells = (struct scm*)arena;
1673 ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
1674 (if (.function info)
1675 (let* ((locals (add-local locals name `("struct" ,type) 1))
1676 (info (clone info #:locals locals)))
1677 (append-text info (append ((ident->accu info) name)
1678 ((accu->ident info) value)))) ;; FIXME: deref?
1679 (let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
1680 (info (clone info #:globals globals)))
1681 (append-text info (append ((ident->accu info) name)
1682 ((accu->ident info) value)))))) ;; FIXME: deref?
1686 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1687 (if (.function info)
1688 (clone info #:locals (add-local locals name type 0))
1689 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1692 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1693 (let ((value (cstring->number value)))
1694 (if (.function info)
1695 (let* ((locals (add-local locals name type 0))
1696 (info (clone info #:locals locals)))
1697 (append-text info ((value->ident info) name value)))
1698 (let ((globals (append globals (list (ident->global name type 0 value)))))
1699 (clone info #:globals globals)))))
1701 ;; SCM g_stack = 0; // comment
1702 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1703 ((ast->info info) (list-head o (- (length o) 1))))
1706 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1707 (if (.function info)
1708 (let* ((locals (add-local locals name type 0))
1709 (info (clone info #:locals locals)))
1710 (append-text info (append ((ident->accu info) local)
1711 ((accu->ident info) name))))
1712 (let* ((globals (append globals (list (ident->global name type 0 0))))
1713 (info (clone info #:globals globals)))
1714 (append-text info (append ((ident->accu info) local)
1715 ((accu->ident info) name))))))
1717 ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1718 ((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))))
1719 (let* ((locals (add-local locals name type 1))
1720 (info (clone info #:locals locals))
1721 (empty (clone info #:text '()))
1722 (accu ((expr->accu empty) initzer)))
1727 ((accu->ident info) name)
1728 (list `(lambda (f g ta t d)
1729 (append (i386:value->base ta)
1730 (i386:accu+base)))))
1733 ;; char *p = (char*)g_cells;
1734 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
1735 (if (.function info)
1736 (let* ((locals (add-local locals name type 1))
1737 (info (clone info #:locals locals)))
1738 (append-text info (append ((ident->accu info) value)
1739 ((accu->ident info) name))))
1740 (let* ((globals (append globals (list (ident->global name type 1 0)))))
1743 #:init (append (.init info)
1745 `(lambda (f g ta t d data)
1746 (let ((here (data-offset ,name g))
1747 (there (data-offset ,value g)))
1749 (list-head data here)
1752 (int->bv32 (+ d (data-offset ,value g)))
1754 ;;(list-head (list-tail data there) 4)
1755 (list-tail data (+ here 4)))))))))))
1757 ;; char *p = g_cells;
1758 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1759 (let ((type (decl->type type)))
1760 (if (.function info)
1761 (let* ((locals (add-local locals name type 1))
1762 (info (clone info #:locals locals)))
1763 (append-text info (append ((ident->accu info) value)
1764 ((accu->ident info) name))))
1765 (let* ((globals (append globals (list (ident->global name type 1 0)))))
1768 #:init (append (.init info)
1769 (list `(lambda (f g ta t d data)
1770 (let ((here (data-offset ,name g)))
1772 (list-head data here)
1774 ;; char *x = arena;p
1775 (int->bv32 (+ d (data-offset ,value g)))
1776 (list-tail data (+ here 4))))))))))))
1779 ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1780 (let ((type (enum->type name fields))
1781 (constants (let loop ((fields fields) (i 0) (constants constants))
1782 (if (null? fields) constants
1783 (let* ((field (car fields))
1785 ((enum-defn (ident ,name) . _) name)))
1787 ((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
1788 ((enum-defn ,name) i))))
1791 (append constants (list (ident->constant name i)))))))))
1793 #:types (append (.types info) (list type))
1794 #:constants (append constants (.constants info)))))
1797 ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1798 (let ((type (struct->type (list "struct" name) (map struct-field fields))))
1799 (clone info #:types (append (.types info) (list type)))))
1801 ;; struct foo {} bar;
1802 ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
1803 (init-declr-list (init-declr (ident ,name))))
1804 (let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
1806 `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
1808 ;; struct foo* bar = expr;
1809 ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1810 (if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
1811 (info (clone info #:locals locals)))
1812 (append-text info (append ((ident-address->accu info) value)
1813 ((accu->ident info) name))))
1814 (error "ast->info: unsupported global:" o)))
1817 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1818 (let ((type (decl->type type)))
1819 (if (.function info)
1820 (let* ((locals (add-local locals name type 1))
1821 (info (clone info #:locals locals)))
1822 (append-text info (append ((ident-address->accu info) value)
1823 ((accu->ident info) name))))
1827 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
1828 (let ((type (decl->type type)))
1829 (if (.function info)
1830 (let* ((locals (add-local locals name type 2))
1831 (info (clone info #:locals locals)))
1832 (append-text info (append ((ident-address->accu info) value)
1833 ((accu->ident info) name))))
1836 ;; char *p = bla[0];
1837 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (array-ref ,index (p-expr (ident ,array)))))))
1838 (if (.function info)
1839 (let* ((locals (add-local locals name type 1))
1840 (info (clone info #:locals locals))
1841 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1842 (append-text info ((accu->ident info) name)))
1845 ;; char *foo = &bar[0];
1846 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (array-ref ,index (p-expr (ident ,array))))))))
1847 (if (.function info)
1848 (let* ((locals (add-local locals name type 1))
1849 (info (clone info #:locals locals))
1850 (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
1851 (append-text info ((accu->ident info) name)))
1855 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (de-ref (p-expr (ident ,value)))))))
1856 (if (.function info)
1857 (let* ((locals (add-local locals name type 1))
1858 (info (clone info #:locals locals))
1859 (local (assoc-ref (.locals info) name)))
1860 (append-text info (append ((ident->accu info) value)
1861 (wrap-as (i386:mem->accu))
1862 ((accu->ident info) name))))
1866 ;; char *bla[] = {"a", "b"};
1867 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
1868 (let* ((type (decl->type type))
1869 (entries (map initzer->global initzers))
1871 (size (* (length entries) entry-size))
1872 (initzers (map (initzer->non-const info) initzers)))
1873 (if (.function info)
1874 (error "TODO: <type> x[] = {};" o)
1875 (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
1876 (globals (append globals entries (list global)))
1877 (info (clone info #:globals globals)))
1882 `(lambda (f g ta t d data)
1883 (let ((here (data-offset ,name g)))
1885 (list-head data here)
1888 (initzer->data f g ta t d i))
1890 (list-tail data (+ here ,size))))))))))))
1893 ;; struct f = {...};
1894 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1895 (let* ((type (decl->type type))
1896 (fields (type->description info type))
1897 (size (type->size info type))
1898 (field-size 4) ;; FIXME:4, not fixed
1899 (initzers (map (initzer->non-const info) initzers)))
1900 (if (.function info)
1901 (let* ((globals (append globals (filter-map initzer->global initzers)))
1902 (locals (let loop ((fields (cdr fields)) (locals locals))
1903 (if (null? fields) locals
1904 (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1905 (locals (add-local locals name type -1))
1906 (info (clone info #:locals locals #:globals globals))
1907 (empty (clone info #:text '())))
1908 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1909 (if (null? fields) info
1910 (let ((offset (* field-size (car fields)))
1911 (initzer (car initzers)))
1912 (loop (cdr fields) (cdr initzers)
1916 ((ident->accu info) name)
1917 (wrap-as (append (i386:accu->base)))
1918 (.text ((expr->accu empty) initzer))
1919 (wrap-as (i386:accu->base-address+n offset)))))))))
1920 (let* ((globals (append globals (filter-map initzer->global initzers)))
1921 (global (make-global name type -1 (string->list (make-string size #\nul))))
1922 (globals (append globals (list global)))
1923 (info (clone info #:globals globals))
1925 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1926 (if (null? fields) info
1927 (let ((offset (* field-size (car fields)))
1928 (initzer (car initzers)))
1929 (loop (cdr fields) (cdr initzers)
1934 `(lambda (f g ta t d data)
1935 (let ((here (data-offset ,name g)))
1937 (list-head data (+ here ,offset))
1938 (initzer->data f g ta t d ',(car initzers))
1939 (list-tail data (+ here ,offset ,field-size))))))))))))))))
1942 ;;char cc = g_cells[c].cdr; ==> generic?
1943 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
1944 (let ((type (decl->type type))
1945 (initzer ((initzer->non-const info) initzer)))
1946 (if (.function info)
1947 (let* ((locals (add-local locals name type 0))
1948 (info (clone info #:locals locals)))
1950 (append (.text ((expr->accu info) initzer))
1951 ((accu->ident info) name))))
1952 (let* ((globals (append globals (list (ident->global name type 1 0)))))
1955 #:init (append (.init info)
1957 `(lambda (f g ta t d data)
1958 (let ((here (data-offset ,name g)))
1960 (list-head data here)
1961 (initzer->data f g ta t d ',initzer)
1962 (list-tail data (+ here 4))))))))))))
1965 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1968 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
1971 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1972 (let ((types (.types info)))
1973 (clone info #:types (cons (cons name (assoc-ref types type)) types))))
1976 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1980 ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
1984 ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1987 ;; char const* itoa ();
1988 ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
1992 ((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))))))
1995 ;; printf (char const* format, ...)
1996 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
1999 ;; int i = 0, j = 0;
2000 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
2001 (let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
2002 (if (null? inits) info
2005 `(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
2007 ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2008 (format (current-error-port) "SKIP: typedef=~s\n" o)
2012 (format (current-error-port) "SKIP: at=~s\n" o)
2015 ((decl . _) (error "ast->info: unsupported: " o))
2018 ((gt . _) ((expr->accu info) o))
2019 ((ge . _) ((expr->accu info) o))
2020 ((ne . _) ((expr->accu info) o))
2021 ((eq . _) ((expr->accu info) o))
2022 ((le . _) ((expr->accu info) o))
2023 ((lt . _) ((expr->accu info) o))
2024 ((lshift . _) ((expr->accu info) o))
2025 ((rshift . _) ((expr->accu info) o))
2028 ((expr-stmt ,expression)
2029 (let ((info ((expr->accu info) expression)))
2030 (append-text info (wrap-as (i386:accu-zero?)))))
2032 ;; FIXME: why do we get (post-inc ...) here
2034 (_ (let ((info ((expr->accu info) o)))
2035 (append-text info (wrap-as (i386:accu-zero?)))))))))
2037 (define (initzer->non-const info)
2040 ((initzer (p-expr (ident ,name)))
2041 (let ((value (assoc-ref (.constants info) name)))
2042 `(initzer (p-expr (fixed ,(number->string value))))))
2045 (define (initzer->data f g ta t d o)
2047 ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2048 ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2049 ((initzer (ref-to (p-expr (ident ,name))))
2050 (int->bv32 (+ ta (function-offset name f))))
2051 ((initzer (p-expr (string ,string)))
2052 (int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
2053 (_ (error "initzer->data: unsupported: " o))))
2055 (define (.formals o)
2057 ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2058 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2059 ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
2060 (_ (error ".formals: " o))))
2062 (define (formal->text n)
2068 (define (formals->text o)
2070 ((param-list . ,formals)
2071 (let ((n (length formals)))
2072 (wrap-as (append (i386:function-preamble)
2073 (append-map (formal->text n) formals (iota n))
2074 (i386:function-locals)))))
2075 (_ (error "formals->text: unsupported: " o))))
2077 (define (formal:ptr o)
2079 ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2081 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2083 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
2085 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2087 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2090 (stderr "formal:ptr[~a] => ~a\n" o 0)
2093 (define (formals->locals o)
2095 ((param-list . ,formals)
2096 (let ((n (length formals)))
2097 (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2098 (_ (error "formals->locals: unsupported: " o))))
2100 (define (function->info info)
2102 (define (assert-return text)
2103 (let ((return (wrap-as (i386:ret))))
2104 (if (equal? (list-tail text (- (length text) (length return))) return) text
2105 (append text return))))
2106 (let* ((name (.name o))
2107 (formals (.formals o))
2108 (text (formals->text formals))
2109 (locals (formals->locals formals)))
2110 (format (current-error-port) "compiling: ~a\n" name)
2111 (let loop ((statements (.statements o))
2112 (info (clone info #:locals locals #:function (.name o) #:text text)))
2113 (if (null? statements) (clone info
2115 #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
2116 (let* ((statement (car statements)))
2117 (loop (cdr statements)
2118 ((ast->info info) (car statements)))))))))
2120 (define (ast-list->info info)
2122 (let loop ((elements elements) (info info))
2123 (if (null? elements) info
2124 (loop (cdr elements) ((ast->info info) (car elements)))))))
2126 (define current-eval
2127 (let ((module (current-module)))
2128 (lambda (e) (eval e module))))
2130 (define (object->list object)
2131 (text->list (map current-eval object)))
2133 (define (dec->xhex o)
2134 (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
2136 (define (write-lambda o)
2139 (if (or (not (pair? o))
2140 (not (eq? (caaddr o) 'list))) (write o)
2141 (list (car o) (cadr o)
2142 (display (string-append "(lambda (f g ta t d) (list "
2143 (string-join (map dec->xhex (cdaddr o)) " ")
2146 (define (write-function o)
2147 (stderr "function: ~s\n" (car o))
2150 (write (car o)) (display " ")
2151 (if (not (cdr o)) (display ". #f")
2152 (for-each write-lambda (cdr o)))
2155 (define (write-info o)
2156 (stderr "object:\n")
2157 (display "(make <info>\n")
2158 (display " #:types\n '") (pretty-print (.types o) #:width 80)
2159 (display " #:constants\n '") (pretty-print (.constants o) #:width 80)
2160 (display " #:functions '(") (for-each write-function (.functions o)) (display ")") (newline)
2161 (stderr "globals:\n")
2162 (display " #:globals\n '") (pretty-print (.globals o) #:width 80)
2164 (display " #:init\n '") (pretty-print (.init o) #:width 80)
2167 (define* (c99-input->info #:key (defines '()) (includes '()))
2169 (let* ((info (make <info> #:types i386:type-alist))
2170 (foo (stderr "parsing: input\n"))
2171 (ast (c99-input->ast #:defines defines #:includes includes))
2172 (foo (stderr "compiling: input\n"))
2173 (info ((ast->info info) ast))
2174 (info (clone info #:text '() #:locals '())))
2177 (define (write-any x)
2178 (write-char (cond ((char? x) x)
2179 ((and (number? x) (< (+ x 256) 0))
2180 (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
2181 ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
2183 (stderr "write-any: proc: ~a\n" x)
2184 (stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
2185 (error "procedure: write-any:" x))
2186 (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
2188 (define (info->elf info)
2189 (display "dumping elf\n" (current-error-port))
2190 (for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info))))
2192 (define (function:object->text o)
2193 (cons (car o) (and (cdr o) (map current-eval (cdr o)))))
2195 (define (init:object->text o)
2198 (define (info:object->text o)
2200 #:functions (map function:object->text (.functions o))
2201 #:init (map init:object->text (.init o))))
2203 (define* (c99-ast->info ast)
2204 ((ast->info (make <info> #:types i386:type-alist)) ast))
2206 (define* (c99-input->elf #:key (defines '()) (includes '()))
2207 ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
2209 (define* (c99-input->object #:key (defines '()) (includes '()))
2210 ((compose write-info (c99-input->info #:defines defines #:includes includes))))
2212 (define (object->elf info)
2213 ((compose info->elf info:object->text) info))
2215 (define (infos->object infos)
2216 ((compose write-info merge-infos) infos))
2218 (define (infos->elf infos)
2219 ((compose object->elf merge-infos) infos))
2221 (define (merge-infos infos)
2222 (let loop ((infos infos) (info (make <info>)))
2223 (if (null? infos) info
2226 #:types (alist-add (.types info) (.types (car infos)))
2227 #:constants (alist-add (.constants info) (.constants (car infos)))
2228 #:functions (alist-add (.functions info) (.functions (car infos)))
2229 #:globals (alist-add (.globals info) (.globals (car infos)))
2230 #:init (append (.init info) (.init (car infos))))))))
2232 (define (alist-add a b)
2233 (let* ((b-keys (map car b))
2234 (a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a))
2235 (a-keys (map car a)))
2236 (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))