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 (nyacc lang c99 parser))
34 (mes-use-module (mes elf-util))
35 (mes-use-module (mes pmatch))
36 (mes-use-module (mes elf))
37 (mes-use-module (mes as-i386))
38 (mes-use-module (mes libc))
39 (mes-use-module (mes optargs))))
41 (define (logf port string . rest)
42 (apply format (cons* port string rest))
46 (define (stderr string . rest)
47 (apply logf (cons* (current-error-port) string rest)))
49 (define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
53 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
65 (write-char (cond ((char? x) x)
66 ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
67 ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
69 (stderr "write-any: proc: ~a\n" x)
70 (stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
72 (else (stderr "write-any: ~a\n" x) barf))))
74 (define (ast:function? o)
75 (and (pair? o) (eq? (car o) 'fctn-defn)))
79 ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
80 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
81 ((param-decl _ (param-declr (ident ,name))) name)
82 ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
83 ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
85 (format (current-error-port) "SKIP: .name =~a\n" o))))
89 ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
90 ((param-decl ,type _) type)
92 (format (current-error-port) "SKIP: .type =~a\n" o))))
94 (define (.statements o)
96 ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
97 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
99 (define <info> '<info>)
100 (define <types> '<types>)
101 (define <constants> '<constants>)
102 (define <functions> '<functions>)
103 (define <globals> '<globals>)
104 (define <init> '<init>)
105 (define <locals> '<locals>)
106 (define <function> '<function>)
107 (define <text> '<text>)
109 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()))
113 (cons <constants> constants)
114 (cons <functions> functions)
115 (cons <globals> globals)
117 (cons <locals> locals)
118 (cons <function> function)
119 (cons <text> text)))))
123 ((<info> . ,alist) (assq-ref alist <types>))))
125 (define (.constants o)
127 ((<info> . ,alist) (assq-ref alist <constants>))))
129 (define (.functions o)
131 ((<info> . ,alist) (assq-ref alist <functions>))))
135 ((<info> . ,alist) (assq-ref alist <globals>))))
139 ((<info> . ,alist) (assq-ref alist <init>))))
143 ((<info> . ,alist) (assq-ref alist <locals>))))
145 (define (.function o)
147 ((<info> . ,alist) (assq-ref alist <function>))))
151 ((<info> . ,alist) (assq-ref alist <text>))))
154 (and (pair? o) (eq? (car o) <info>)))
156 (define (clone o . rest)
158 (let ((types (.types o))
159 (constants (.constants o))
160 (functions (.functions o))
161 (globals (.globals o))
164 (function (.function o))
169 (constants constants)
170 (functions functions)
176 (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text))))))
178 (define (push-global globals)
182 (i386:push-global (+ (data-offset o g) d))))))
184 (define (push-local locals)
188 (i386:push-local (local:id o))))))
190 (define (push-global-address globals)
194 (i386:push-global-address (+ (data-offset o g) d))))))
196 (define (push-local-address locals)
200 (i386:push-local-address (local:id o))))))
202 (define push-global-de-ref push-global)
204 (define (push-local-de-ref locals)
208 (i386:push-local-de-ref (local:id o))))))
210 (define (string->global string)
211 (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
213 (define (ident->global name type pointer value)
214 (make-global name type pointer (int->bv32 value)))
216 (define (make-local name type pointer id)
217 (cons name (list type pointer id)))
218 (define local:type car)
219 (define local:pointer cadr)
220 (define local:id caddr)
222 (define (push-ident info)
224 (let ((local (assoc-ref (.locals info) o)))
225 (if local ((push-local (.locals info)) local)
226 (let ((global (assoc-ref (.globals info) o)))
228 ((push-global (.globals info)) o) ;; FIXME: char*/int
229 (let ((constant (assoc-ref (.constants info) o)))
231 (list (lambda (f g ta t d)
233 (i386:value->accu constant)
235 TODO:push-function))))))))
237 (define (push-ident-address info)
239 (let ((local (assoc-ref (.locals info) o)))
240 (if local ((push-local-address (.locals info)) local)
241 ((push-global-address (.globals info)) o)))))
243 (define (push-ident-de-ref info)
245 (let ((local (assoc-ref (.locals info) o)))
246 (if local ((push-local-de-ref (.locals info)) local)
247 ((push-global-de-ref (.globals info)) o)))))
249 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
251 (let ((text (.text info)))
252 ;;(stderr "expr->arg o=~s\n" o)
254 ((p-expr (fixed ,value))
255 (let ((value (cstring->number value)))
256 (clone info #:text (append text
260 (i386:value->accu value)
261 (i386:push-accu))))))))
263 ((neg (p-expr (fixed ,value)))
264 (let ((value (- (cstring->number value))))
265 (clone info #:text (append text
269 (i386:value->accu value)
270 (i386:push-accu))))))))
272 ((p-expr (string ,string))
273 (clone info #:text (append text ((push-global-address info) (add-s:-prefix string)))))
275 ((p-expr (ident ,name))
276 (clone info #:text (append text ((push-ident info) name))))
279 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
280 (let* ((index (cstring->number index))
281 (type (ident->type info array))
282 (size (type->size info type)))
285 ((ident->base info) array)
289 (i386:value->accu (* size index))
291 (i386:byte-base-mem->accu)
292 (i386:base-mem->accu))
293 (i386:push-accu))))))))
296 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
297 (let* ((type (ident->type info array))
298 (size (type->size info type)))
299 (clone info #:text (append text
300 ((ident->base info) index)
301 (list (lambda (f g ta t d)
307 (if (= size 12) (i386:accu+base) '())
309 ((ident->base info) array)
310 (list (lambda (f g ta t d)
312 (i386:byte-base-mem->accu)
313 (i386:base-mem->accu))))
316 (i386:push-accu)))))))
318 ((de-ref (p-expr (ident ,name)))
319 (clone info #:text (append text ((push-ident-de-ref info) name))))
321 ((ref-to (p-expr (ident ,name)))
322 (clone info #:text (append text ((push-ident-address info) name))))
326 (let* (;;(empty (clone info #:text '()))
327 ;;(info ((ast->info empty) o))
328 (info ((ast->info info) o))
334 (i386:push-accu)))))))
338 (let* (;;(empty (clone info #:text '()))
339 ;;(expr ((expr->accu empty) `(d-sel ,@d-sel)))
340 (expr ((expr->accu info) `(d-sel ,@d-sel)))
344 (list (lambda (f g ta t d)
345 (i386:push-accu)))))))
348 ((p-expr (char ,char))
349 (let ((char (char->integer (car (string->list char)))))
352 (list (lambda (f g ta t d)
354 (i386:value->accu char)
355 (i386:push-accu)))))))
359 ;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
361 ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
362 (abs-declr (pointer)))
364 ((expr->arg info) cast))
367 ;; (stderr "catch: expr->arg=~s\n" o)
368 (let* ((info ((expr->accu info) o))
372 (list (lambda (f g ta t d)
375 (i386:push-accu))))))))
378 (stderr "SKIP: expr->arg=~s\n" o)
382 ;; FIXME: see ident->base
383 (define (ident->accu info)
385 (let ((local (assoc-ref (.locals info) o))
386 (global (assoc-ref (.globals info) o))
387 (constant (assoc-ref (.constants info) o)))
388 ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
389 ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
390 ;; (stderr "globals: ~a\n" (.globals info))
391 ;; (if (and (not global) (not (local:id local)))
392 ;; (stderr "globals: ~a\n" (map car (.globals info))))
394 (let* ((ptr (local:pointer local))
395 (type (ident->type info o))
396 (size (and type (type->size info type))))
397 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
398 ;;(stderr "type: ~s\n" type)
399 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
400 ;;(stderr "locals: ~s\n" locals)
402 ((-1) (list (lambda (f g ta t d)
403 (i386:local-ptr->accu (local:id local)))))
404 ((1) (list (lambda (f g ta t d)
405 (i386:local->accu (local:id local)))))
407 (list (lambda (f g ta t d)
409 (i386:byte-local->accu (local:id local))
410 (i386:local->accu (local:id local))))))))
412 (let ((ptr (ident->pointer info o)))
413 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
415 ((-1) (list (lambda (f g ta t d)
416 (i386:global->accu (+ (data-offset o g) d)))))
417 (else (list (lambda (f g ta t d)
418 (i386:global-address->accu (+ (data-offset o g) d)))))))
420 (list (lambda (f g ta t d)
421 (i386:value->accu constant)))
422 (list (lambda (f g ta t d)
423 (i386:global->accu (+ ta (function-offset o f)))))))))))
425 (define (value->accu v)
426 (list (lambda (f g ta t d)
427 (i386:value->accu v))))
429 (define (accu->ident info)
431 (let ((local (assoc-ref (.locals info) o)))
433 (list (lambda (f g ta t d)
434 (i386:accu->local (local:id local))))
435 (list (lambda (f g ta t d)
436 (i386:accu->global (+ (data-offset o g) d))))))))
438 (define (base->ident info)
440 (let ((local (assoc-ref (.locals info) o)))
442 (list (lambda (f g ta t d)
443 (i386:base->local (local:id local))))
444 (list (lambda (f g ta t d)
445 (i386:base->global (+ (data-offset o g) d))))))))
447 (define (base->ident-address info)
449 (let ((local (assoc-ref (.locals info) o)))
451 (list (lambda (f g ta t d)
453 (i386:local->accu (local:id local))
454 (i386:byte-base->accu-address))))
455 TODO:base->ident-address-global))))
457 (define (value->ident info)
459 (let ((local (assoc-ref (.locals info) o)))
461 (list (lambda (f g ta t d)
462 (i386:value->local (local:id local) value)))
463 (list (lambda (f g ta t d)
464 (i386:value->global (+ (data-offset o g) d) value)))))))
466 (define (ident-add info)
468 (let ((local (assoc-ref (.locals info) o)))
470 (list (lambda (f g ta t d)
471 (i386:local-add (local:id local) n)))
472 (list (lambda (f g ta t d)
473 (i386:global-add (+ (data-offset o g) d) n)))))))
475 ;; FIXME: see ident->accu
476 (define (ident->base info)
478 (let ((local (assoc-ref (.locals info) o)))
479 ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
481 (let* ((ptr (local:pointer local))
482 (type (ident->type info o))
483 (size (and type (type->size info type))))
485 ((-1) (list (lambda (f g ta t d)
486 (i386:local-ptr->base (local:id local)))))
487 ((1) (list (lambda (f g ta t d)
488 (i386:local->base (local:id local)))))
490 (list (lambda (f g ta t d)
492 (i386:byte-local->base (local:id local))
493 (i386:local->base (local:id local))))))))
494 (let ((global (assoc-ref (.globals info) o) ))
496 (let ((ptr (ident->pointer info o)))
497 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
499 ((-1) (list (lambda (f g ta t d)
500 (i386:global->base (+ (data-offset o g) d)))))
501 (else (list (lambda (f g ta t d)
502 (i386:global-address->base (+ (data-offset o g) d)))))))
503 (let ((constant (assoc-ref (.constants info) o)))
505 (list (lambda (f g ta t d)
506 (i386:value->base constant)))
507 (list (lambda (f g ta t d)
508 (i386:global->base (+ ta (function-offset o f)))))))))))))
510 (define (expr->accu info)
512 (let ((text (.text info))
513 (locals (.locals info))
514 (globals (.globals info)))
515 ;;(stderr "expr->accu o=~a\n" o)
517 ((p-expr (string ,string))
518 (clone info #:text (append text (list (lambda (f g ta t d)
519 ;;(stderr "OFF[~a]: ~a\n" string (data-offset string globals))
520 ;;(stderr "globals: ~s\n" (map car globals))
521 (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
522 ((p-expr (fixed ,value))
523 (clone info #:text (append text (value->accu (cstring->number value)))))
524 ((p-expr (ident ,name))
525 (clone info #:text (append text ((ident->accu info) name))))
526 ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
527 ((not (fctn-call . _)) ((ast->info info) o))
528 ((neg (p-expr (fixed ,value)))
529 (clone info #:text (append text (value->accu (- (cstring->number value))))))
531 ((initzer ,initzer) ((expr->accu info) initzer))
532 ((ref-to (p-expr (ident ,name)))
535 ((ident->accu info) name))))
537 ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
538 (let* ((type (list "struct" name))
539 (fields (or (type->description info type) '()))
540 (size (type->size info type)))
543 (list (lambda (f g ta t d)
545 (i386:value->accu size))))))))
548 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
549 (let* ((index (cstring->number index))
550 (type (ident->type info array))
551 (size (type->size info type)))
554 ((ident->base info) array)
555 (list (lambda (f g ta t d)
557 (i386:value->accu (* size index))
559 (i386:byte-base-mem->accu)
560 (i386:base-mem->accu)))))))))
563 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
564 (let* ((type (ident->type info array))
565 (size (type->size info type)))
566 (clone info #:text (append text
567 ((ident->base info) index)
568 (list (lambda (f g ta t d)
574 (if (= size 12) (i386:accu+base) '())
576 ((ident->base info) array)
577 (list (lambda (f g ta t d)
579 (i386:byte-base-mem->accu)
580 (i386:base-mem->accu))))))))
583 ((d-sel (ident ,field) (p-expr (ident ,array)))
584 (let* ((type (ident->type info array))
585 (fields (type->description info type))
586 (field-size 4) ;; FIXME:4, not fixed
587 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
591 ((ident->accu info) array)
592 (list (lambda (f g ta t d)
593 (i386:mem+n->accu offset)))))))
596 ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
597 (let* ((type (ident->type info array))
598 (fields (or (type->description info type) '()))
599 (size (type->size info type))
600 (count (length fields))
601 (field-size 4) ;; FIXME:4, not fixed
602 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
603 (index (cstring->number index))
607 (list (lambda (f g ta t d)
609 (i386:value->base index)
611 (if (> count 1) (i386:accu+accu) '())
612 (if (= count 3) (i386:accu+base) '())
614 ((ident->base info) array)
615 (list (lambda (f g ta t d)
616 (i386:base-mem+n->accu offset)))))))
619 ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
620 (let* ((type (ident->type info array))
621 (fields (or (type->description info type) '()))
622 (size (type->size info type))
623 (count (length fields))
624 (field-size 4) ;; FIXME:4, not fixed
625 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
629 ((ident->base info) index)
630 (list (lambda (f g ta t d)
633 (if (> count 1) (i386:accu+accu) '())
634 (if (= count 3) (i386:accu+base) '())
636 ((ident->base info) array)
637 (list (lambda (f g ta t d)
638 (i386:base-mem+n->accu offset)))))))
640 ;; g_functions[g_cells[fn].cdr].arity
641 ;; INDEX0: g_cells[fn].cdr
643 ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
644 ;;((d-sel (ident ,arity) (array-ref (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells)))) (p-expr (ident ,g_functions)))))
645 ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
646 (let* ((empty (clone info #:text '()))
647 (index ((expr->accu empty) index))
648 (type (ident->type info array))
649 (fields (or (type->description info type) '()))
650 (size (type->size info type))
651 (count (length fields))
652 (field-size 4) ;; FIXME:4, not fixed
653 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
656 (offset (* field-size (1- (length rest))))
661 (list (lambda (f g ta t d)
664 (if (> count 1) (i386:accu+accu) '())
665 (if (= count 3) (i386:accu+base) '())
667 ((ident->base info) array)
668 (list (lambda (f g ta t d)
669 (i386:base-mem+n->accu offset)))))))
671 ;;; FIXME: FROM INFO ...only zero?!
672 ((p-expr (fixed ,value))
673 (let ((value (cstring->number value)))
676 (list (lambda (f g ta t d)
677 (i386:value->accu value)))))))
679 ((p-expr (char ,char))
680 (let ((char (char->integer (car (string->list char)))))
683 (list (lambda (f g ta t d)
684 (i386:value->accu char)))))))
686 ((p-expr (ident ,name))
689 ((ident->accu info) name))))
691 ((de-ref (p-expr (ident ,name)))
692 (let* ((type (ident->type info name))
693 (size (and type (type->size info type))))
696 ((ident->accu info) name)
697 (list (lambda (f g ta t d)
699 (i386:byte-mem->accu)
700 (i386:mem->accu))))))))
702 ;; GRR --> info again??!?
704 ((ast->info info) `(expr-stmt ,o)))
706 ((cond-expr . ,cond-expr)
707 ((ast->info info) `(expr-stmt ,o)))
710 ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
711 ((post-inc (p-expr (ident ,name)))
714 ((ident->accu info) name)
715 ((ident-add info) name 1))))
717 ;; GRR --> info again??!?
718 ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
719 ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
720 ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
721 ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
723 ((add (p-expr (ident ,name)) ,b)
724 (let* ((empty (clone info #:text '()))
725 (base ((expr->base empty) b)))
729 ((ident->accu info) name)
730 (list (lambda (f g ta t d)
731 (i386:accu+base)))))))
734 (let* ((empty (clone info #:text '()))
735 (accu ((expr->accu empty) a))
736 (base ((expr->base empty) b)))
741 (list (lambda (f g ta t d)
742 (i386:accu+base)))))))
745 (let* ((empty (clone info #:text '()))
746 (accu ((expr->accu empty) a))
747 (base ((expr->base empty) b)))
752 (list (lambda (f g ta t d)
753 (i386:accu-base)))))))
755 ((lshift ,a (p-expr (fixed ,value)))
756 (let* ((empty (clone info #:text '()))
757 (accu ((expr->accu empty) a))
758 (value (cstring->number value)))
762 (list (lambda (f g ta t d)
763 (i386:accu-shl value)))))))
766 (let* ((empty (clone info #:text '()))
767 (accu ((expr->accu empty) a))
768 (base ((expr->base empty) b)))
773 (list (lambda (f g ta t d)
774 (i386:accu/base)))))))
777 (let* ((empty (clone info #:text '()))
778 (accu ((expr->accu empty) a))
779 (base ((expr->base empty) b)))
781 (append text ;;FIXME:empty
784 (list (lambda (f g ta t d)
785 (i386:accu%base)))))))
787 ;; FIXME: c/p ast->info
789 (let* ((base ((expr->base info) a))
790 (empty (clone base #:text '()))
791 (accu ((expr->accu empty) b)))
794 (list (lambda (f g ta t d)
798 (list (lambda (f g ta t d)
799 (i386:sub-base)))))))
801 ;; FIXME: c/p ast->info
803 (let* ((base ((expr->base info) a))
804 (empty (clone base #:text '()))
805 (accu ((expr->accu empty) b)))
809 (list (lambda (f g ta t d)
810 (i386:base-sub)))))))
812 ;; FIXME: ...c/p ast->info
813 ((neg (p-expr (ident ,name)))
814 (clone info #:text (append text
815 ((ident->base info) name)
816 (list (lambda (f g ta t d)
817 (i386:value->accu 0)))
818 (list (lambda (f g ta t d)
821 ;;((cast (type-name (decl-spec-list (type-spec (typename "SCM"))) (abs-declr (declr-fctn (declr-scope (abs-declr (pointer))) (param-list (param-decl (decl-spec-list (type-spec (typename "SCM")))))))) (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "functions"))))))
823 ((expr->accu info) o))
825 ((assn-expr (p-expr (ident ,name)) ,op ,expr)
826 (let ((info ((ast->info info) o)))
827 (clone info #:text (append (.text info)
828 ((ident->accu info) name)))))
831 (format (current-error-port) "SKIP: expr->accu=~s\n" o)
835 (define (expr->base info)
837 (let ((info ((expr->accu info) o)))
840 (list (lambda (f g ta t d)
843 (list (lambda (f g ta t d)
846 (i386:pop-accu)))))))))
848 (define (expr->accu* info)
851 ;;(stderr "expr->accu* o=~s\n" o)
853 ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
854 (let* ((type (ident->type info array))
855 (fields (or (type->description info type) '()))
856 (size (type->size info type))
857 (count (length fields))
858 (field-size 4) ;; FIXME:4, not fixed
859 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
860 (index (cstring->number index))
864 (list (lambda (f g ta t d)
866 (i386:value->base index)
868 (if (> count 1) (i386:accu+accu) '())
869 (if (= count 3) (i386:accu+base) '())
871 ;; de-ref: g_cells, non: arena
872 ;;((ident->base info) array)
873 ((ident->base info) array)
874 (list (lambda (f g ta t d)
877 (i386:accu+value offset))))))))
880 ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
881 (let* ((type (ident->type info array))
882 (fields (or (type->description info type) '()))
883 (size (type->size info type))
884 (count (length fields))
885 (field-size 4) ;; FIXME:4, not fixed
886 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
890 ((ident->base info) index)
891 (list (lambda (f g ta t d)
894 (if (> count 1) (i386:accu+accu) '())
895 (if (= count 3) (i386:accu+base) '())
897 ;; de-ref: g_cells, non: arena
898 ;;((ident->base info) array)
899 ((ident->base info) array)
900 (list (lambda (f g ta t d)
903 (i386:accu+value offset))))))))
905 ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
906 ((d-sel (ident ,field) (p-expr (ident ,name)))
907 (let* ((type (ident->type info name))
908 (fields (or (type->description info type) '()))
909 (field-size 4) ;; FIXME
910 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
914 ((ident->accu info) name)
915 (list (lambda (f g ta t d)
916 (i386:accu+value offset)))))))
919 (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
924 (define (ident->constant name value)
927 (define (make-type name type size description)
928 (cons name (list type size description)))
930 (define (enum->type name fields)
931 (make-type name 'enum 4 fields))
933 (define (struct->type name fields)
934 (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
936 (define (decl->type o)
938 ((fixed-type ,type) type)
939 ((struct-ref (ident ,name)) (list "struct" name))
940 ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
941 (list "struct" name)) ;; FIXME
942 ((typename ,name) name)
944 (stderr "SKIP: decl type=~s\n" o)
948 (define (expr->global o)
950 ((p-expr (string ,string)) (string->global string))
953 (define (initzer->global o)
955 ((initzer ,initzer) (expr->global initzer))
958 (define (byte->hex o)
959 (string->number (string-drop o 2) 16))
962 (let ((prefix ".byte "))
963 (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
964 (let ((s (string-drop o (string-length prefix))))
965 (map byte->hex (string-split s #\space))))))
967 (define (case->jump-info info)
969 (list (lambda (f g ta t d) (i386:Xjump n))))
971 (list (lambda (f g ta t d) (i386:Xjump-nz n))))
972 (define (statement->info info body-length)
975 ((break) (clone info #:text (append (.text info) (jump body-length)
978 ((ast->info info) o)))))
981 ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
982 (lambda (body-length)
984 (define (test->text value clause-length)
985 (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
986 (jump-nz clause-length)))
987 (let* ((value (assoc-ref (.constants info) constant))
989 (clone info #:text (append (.text info) (test->text value 0))))
990 (text-length (length (.text test-info)))
991 (clause-info (let loop ((elements elements) (info test-info))
992 (if (null? elements) info
993 (loop (cdr elements) ((statement->info info body-length) (car elements))))))
994 (clause-text (list-tail (.text clause-info) text-length))
995 (clause-length (length (text->list clause-text))))
996 (clone info #:text (append
998 (test->text value clause-length)
1000 #:globals (.globals clause-info)))))
1002 ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
1003 (lambda (body-length)
1005 (define (test->text value clause-length)
1006 (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1007 (jump-nz clause-length)))
1008 (let* ((value (cstring->number value))
1010 (clone info #:text (append (.text info) (test->text value 0))))
1011 (text-length (length (.text test-info)))
1012 (clause-info (let loop ((elements elements) (info test-info))
1013 (if (null? elements) info
1014 (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1015 (clause-text (list-tail (.text clause-info) text-length))
1016 (clause-length (length (text->list clause-text))))
1017 (clone info #:text (append
1019 (test->text value clause-length)
1021 #:globals (.globals clause-info)))))
1023 ((case (neg (p-expr (fixed ,value))) ,statement)
1024 ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
1026 ((default (compd-stmt (block-item-list . ,elements)))
1027 (lambda (body-length)
1028 (let ((text-length (length (.text info))))
1029 (let loop ((elements elements) (info info))
1030 (if (null? elements) info
1031 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
1033 ((case (p-expr (ident ,constant)) ,statement)
1034 ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
1036 ((case (p-expr (fixed ,value)) ,statement)
1037 ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
1039 ((default ,statement)
1040 ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
1042 (_ (stderr "no case match: ~a\n" o) barf)
1045 (define (test->jump->info info)
1046 (define (jump type . test)
1048 (let* ((text (.text info))
1049 (info (clone info #:text '()))
1050 (info ((ast->info info) o))
1051 (jump-text (lambda (body-length)
1052 (list (lambda (f g ta t d) (type body-length))))))
1053 (lambda (body-length)
1057 (if (null? test) '() (car test))
1058 (jump-text body-length)))))))
1061 ((lt ,a ,b) ((jump i386:Xjump-nc) o))
1062 ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1063 ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1064 ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1065 ((not _) ((jump i386:Xjump-z) o))
1067 (let* ((text (.text info))
1068 (info (clone info #:text '()))
1070 (a-jump ((test->jump->info info) a))
1071 (a-text (.text (a-jump 0)))
1072 (a-length (length (text->list a-text)))
1074 (b-jump ((test->jump->info info) b))
1075 (b-text (.text (b-jump 0)))
1076 (b-length (length (text->list b-text))))
1078 (lambda (body-length)
1081 (.text (a-jump (+ b-length body-length)))
1082 (.text (b-jump body-length)))))))
1084 (let* ((text (.text info))
1085 (info (clone info #:text '()))
1087 (a-jump ((test->jump->info info) a))
1088 (a-text (.text (a-jump 0)))
1089 (a-length (length (text->list a-text)))
1091 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1092 (jump-length (length (text->list jump-text)))
1094 (b-jump ((test->jump->info info) b))
1095 (b-text (.text (b-jump 0)))
1096 (b-length (length (text->list b-text)))
1098 (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
1100 (lambda (body-length)
1103 (.text (a-jump jump-length))
1105 (.text (b-jump body-length)))))))
1107 ((array-ref . _) ((jump i386:jump-byte-z
1108 (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1110 ((de-ref _) ((jump i386:jump-byte-z
1111 (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1113 ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1116 ((ident->accu info) name)
1117 (list (lambda (f g ta t d) (i386:accu-zero?))))) o))
1119 (_ ((jump i386:Xjump-z (list (lambda (f g ta t d) (i386:accu-zero?)))) o)))))
1121 (define (cstring->number s)
1122 (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1123 ((string-prefix? "0" s) (string->number s 8))
1124 (else (string->number s))))
1126 (define (struct-field o)
1128 ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1129 (comp-declr-list (comp-declr (ident ,name))))
1131 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1133 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1135 ((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)))))))))
1136 (cons type name)) ;; FIXME function / int
1137 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1138 (cons type name)) ;; FIXME: ptr/char
1139 (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1141 (define (ast->type o)
1145 ((struct-ref (ident ,type))
1146 (list "struct" type))
1147 (_ (stderr "SKIP: type=~s\n" o)
1150 (define i386:type-alist
1151 '(("char" . (builtin 1 #f))
1152 ("int" . (builtin 4 #f))))
1154 (define (type->size info o)
1155 ;;(stderr "types=~s\n" (.types info))
1156 ;;(stderr "type->size o=~s => ~s\n" o (cadr (assoc-ref (.types info) o)))
1158 ((decl-spec-list (type-spec (fixed-type ,type)))
1159 (type->size info type))
1160 ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1161 (type->size info type))
1162 (_ (let ((type (assoc-ref (.types info) o)))
1163 (if type (cadr type)
1165 (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1169 (define (ident->decl info o)
1170 ;; (stderr "ident->decl o=~s\n" o)
1171 ;; (stderr " types=~s\n" (.types info))
1172 ;; (stderr " local=~s\n" (assoc-ref (.locals info) o))
1173 ;; (stderr " global=~s\n" (assoc-ref (.globals info) o))
1174 (or (assoc-ref (.locals info) o)
1175 (assoc-ref (.globals info) o)
1177 (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1178 (assoc-ref (.functions info) o))))
1180 (define (ident->type info o)
1181 (and=> (ident->decl info o) car))
1183 (define (ident->pointer info o)
1184 (let ((local (assoc-ref (.locals info) o)))
1185 (if local (local:pointer local)
1186 (or (and=> (ident->decl info o) global:pointer) 0))))
1188 (define (type->description info o)
1189 ;; (stderr "type->description =~s\n" o)
1190 ;; (stderr "types=~s\n" (.types info))
1191 ;; (stderr "type->description o=~s ==> ~s\n" o (caddr (assoc-ref (.types info) o)))
1192 ;; (stderr " assoc ~a\n" (assoc-ref (.types info) o))
1194 ((decl-spec-list (type-spec (fixed-type ,type)))
1195 (type->description info type))
1196 ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1197 (type->description info type))
1198 (_ (caddr (assoc-ref (.types info) o)))))
1200 (define (local? o) ;; formals < 0, locals > 0
1201 (positive? (local:id o)))
1203 (define (ast->info info)
1205 (let ((globals (.globals info))
1206 (locals (.locals info))
1207 (constants (.constants info))
1208 (text (.text info)))
1209 (define (add-local locals name type pointer)
1210 (let* ((id (1+ (length (filter local? (map cdr locals)))))
1211 (locals (cons (make-local name type pointer id) locals)))
1214 ;; (stderr "\n ast->info=~s\n" o)
1215 ;; (stderr " globals[~a=>~a]: ~a\n" (length globals) (length (append-map cdr globals)) (map (lambda (s) (if (string? s) (string-delete #\newline s))) (map car globals)))
1216 ;; (stderr " text=~a\n" text)
1217 ;; (stderr " info=~a\n" info)
1218 ;; (stderr " globals=~a\n" globals)
1220 (((trans-unit . _) . _)
1221 ((ast-list->info info) o))
1222 ((trans-unit . ,elements)
1223 ((ast-list->info info) elements))
1224 ((fctn-defn . _) ((function->info info) o))
1225 ((comment . _) info)
1226 ((cpp-stmt (define (name ,name) (repl ,value)))
1229 ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1232 ;; FIXME: expr-stmt wrapper?
1235 ((assn-expr . ,assn-expr)
1236 ((ast->info info) `(expr-stmt ,o)))
1239 (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1242 ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1244 ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1245 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1246 (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1247 (let* ((globals (append globals (filter-map expr->global expr-list)))
1248 (info (clone info #:globals globals))
1249 (text-length (length text))
1250 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1251 (if (null? expressions) info
1252 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1253 (text (.text args-info))
1254 (n (length expr-list)))
1255 (if (and (not (assoc-ref locals name))
1256 (assoc-ref (.functions info) name))
1257 (clone args-info #:text
1259 (list (lambda (f g ta t d)
1260 (i386:call f g ta t d (+ t (function-offset name f)) n))))
1262 (let* ((empty (clone info #:text '()))
1263 (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1264 (clone args-info #:text
1267 (list (lambda (f g ta t d)
1268 (i386:call-accu f g ta t d n))))
1269 #:globals globals))))))
1271 ;;((expr-stmt (fctn-call (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "g_functions")))) (expr-list))))
1272 ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1273 (let* ((globals (append globals (filter-map expr->global expr-list)))
1274 (info (clone info #:globals globals))
1275 (text-length (length text))
1276 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1277 (if (null? expressions) info
1278 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1279 (text (.text args-info))
1280 (n (length expr-list))
1281 (empty (clone info #:text '()))
1282 (accu ((expr->accu empty) function)))
1286 (list (lambda (f g ta t d)
1287 (i386:call-accu f g ta t d n))))
1288 #:globals globals)))
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 (body-info ((ast->info test+jump-info) body))
1298 (text-body-info (.text body-info))
1299 (body-text (list-tail text-body-info test-length))
1300 (body-length (length (text->list body-text)))
1302 (text+test-text (.text (test-jump->info body-length)))
1303 (test-text (list-tail text+test-text text-length)))
1309 #:globals (.globals body-info))))
1311 ((if ,test ,then ,else)
1312 (let* ((text-length (length text))
1314 (test-jump->info ((test->jump->info info) test))
1315 (test+jump-info (test-jump->info 0))
1316 (test-length (length (.text test+jump-info)))
1318 (then-info ((ast->info test+jump-info) then))
1319 (text-then-info (.text then-info))
1320 (then-text (list-tail text-then-info test-length))
1321 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1322 (then-jump-length (length (text->list then-jump-text)))
1323 (then-length (+ (length (text->list then-text)) then-jump-length))
1325 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1326 (else-info ((ast->info then+jump-info) else))
1327 (text-else-info (.text else-info))
1328 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1329 (else-length (length (text->list else-text)))
1331 (text+test-text (.text (test-jump->info then-length)))
1332 (test-text (list-tail text+test-text text-length))
1333 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1341 #:globals (append (.globals then-info)
1342 (list-tail (.globals else-info) (length globals))))))
1344 ((expr-stmt (cond-expr ,test ,then ,else))
1345 (let* ((text-length (length text))
1347 (test-jump->info ((test->jump->info info) test))
1348 (test+jump-info (test-jump->info 0))
1349 (test-length (length (.text test+jump-info)))
1351 (then-info ((ast->info test+jump-info) then))
1352 (text-then-info (.text then-info))
1353 (then-text (list-tail text-then-info test-length))
1354 (then-length (length (text->list then-text)))
1356 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1357 (jump-length (length (text->list jump-text)))
1359 (test+then+jump-info
1361 #:text (append (.text then-info) jump-text)))
1363 (else-info ((ast->info test+then+jump-info) else))
1364 (text-else-info (.text else-info))
1365 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1366 (else-length (length (text->list else-text)))
1368 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1369 (test-text (list-tail text+test-text text-length))
1370 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1378 #:globals (.globals else-info))))
1380 ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1381 (let* ((expr ((expr->accu info) expr))
1382 (empty (clone info #:text '()))
1383 (case-infos (map (case->jump-info empty) cases))
1384 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1385 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1386 (if (null? cases) info
1387 (let ((c-j ((case->jump-info info) (car cases))))
1388 (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1391 ((for ,init ,test ,step ,body)
1392 (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1394 (info ((ast->info info) init))
1396 (init-text (.text info))
1397 (init-locals (.locals info))
1398 (info (clone info #:text '()))
1400 (body-info ((ast->info info) body))
1401 (body-text (.text body-info))
1402 (body-length (length (text->list body-text)))
1404 (step-info ((ast->info info) `(expr-stmt ,step)))
1405 (step-text (.text step-info))
1406 (step-length (length (text->list step-text)))
1408 (test-jump->info ((test->jump->info info) test))
1409 (test+jump-info (test-jump->info 0))
1410 (test-length (length (text->list (.text test+jump-info))))
1412 (skip-body-text (list (lambda (f g ta t d)
1413 (i386:Xjump (+ body-length step-length)))))
1415 (jump-text (list (lambda (f g ta t d)
1416 (i386:Xjump (- (+ body-length step-length test-length))))))
1417 (jump-length (length (text->list jump-text)))
1419 (test-text (.text (test-jump->info jump-length))))
1429 #:globals (append globals (list-tail (.globals body-info) (length globals)))
1432 ;; FIXME: support break statement (see switch/case)
1433 ((while ,test ,body)
1434 (let* ((skip-info (lambda (body-length)
1435 (clone info #:text (append text
1436 (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
1437 (text (.text (skip-info 0)))
1438 (text-length (length text))
1440 (body-info (lambda (body-length)
1441 ((ast->info (skip-info body-length)) body)))
1442 (body-text (list-tail (.text (body-info 0)) text-length))
1443 (body-length (length (text->list body-text)))
1445 (body-info (body-info body-length))
1447 (empty (clone info #:text '()))
1448 (test-jump->info ((test->jump->info empty) test))
1449 (test+jump-info (test-jump->info 0))
1450 (test-length (length (text->list (.text test+jump-info))))
1452 (jump-text (list (lambda (f g ta t d)
1453 (i386:Xjump (- (+ body-length test-length))))))
1454 (jump-length (length (text->list jump-text)))
1456 (test-text (.text (test-jump->info jump-length))))
1462 #:globals (.globals body-info))))
1464 ((do-while ,body ,test)
1465 (let* ((text-length (length text))
1467 (body-info ((ast->info info) body))
1468 (body-text (list-tail (.text body-info) text-length))
1469 (body-length (length (text->list body-text)))
1471 (empty (clone info #:text '()))
1472 (test-jump->info ((test->jump->info empty) test))
1473 (test+jump-info (test-jump->info 0))
1474 (test-length (length (text->list (.text test+jump-info))))
1476 (jump-text (list (lambda (f g ta t d)
1477 (i386:Xjump (- (+ body-length test-length))))))
1478 (jump-length (length (text->list jump-text)))
1480 (test-text (.text (test-jump->info jump-length))))
1486 #:globals (.globals body-info))))
1488 ((labeled-stmt (ident ,label) ,statement)
1489 (let ((info (clone info #:text (append text (list label)))))
1490 ((ast->info info) statement)))
1492 ((goto (ident ,label))
1493 (let* ((jump (lambda (n) (i386:XXjump n)))
1494 (offset (+ (length (jump 0)) (length (text->list text)))))
1497 (list (lambda (f g ta t d)
1498 (jump (- (label-offset (.function info) label f) offset))))))))
1500 ;;; FIXME: only zero?!
1501 ((p-expr (ident ,name))
1504 ((ident->accu info) name)
1505 (list (lambda (f g ta t d)
1507 (i386:accu-zero?)))))))
1509 ((p-expr (fixed ,value))
1510 (let ((value (cstring->number value)))
1513 (list (lambda (f g ta t d)
1515 (i386:value->accu value)
1516 (i386:accu-zero?))))))))
1518 ((de-ref (p-expr (ident ,name)))
1521 ((ident->accu info) name)
1522 (list (lambda (f g ta t d)
1524 (i386:byte-mem->accu)))))))
1526 ((fctn-call . ,call)
1527 (let ((info ((ast->info info) `(expr-stmt ,o))))
1529 (append (.text info)
1530 (list (lambda (f g ta t d)
1531 (i386:accu-zero?)))))))
1534 ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1535 ((post-inc (p-expr (ident ,name)))
1538 ((ident->accu info) name)
1539 ((ident-add info) name 1)
1540 (list (lambda (f g ta t d)
1542 (i386:accu-zero?)))))))
1543 ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1544 ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1545 ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1546 ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1549 ((expr-stmt (post-inc (p-expr (ident ,name))))
1550 (clone info #:text (append text ((ident-add info) name 1))))
1553 ((expr-stmt (pre-inc (p-expr (ident ,name))))
1554 (or (assoc-ref locals name) barf)
1557 ((ident-add info) name 1)
1558 ((ident->accu info) name)
1559 (list (lambda (f g ta t d)
1561 ;;(i386:local->accu (local:id (assoc-ref locals name)))
1562 (i386:accu-zero?)))))))
1565 ((expr-stmt (post-dec (p-expr (ident ,name))))
1566 (or (assoc-ref locals name) barf)
1569 ((ident->accu info) name)
1570 ((ident-add info) name -1)
1571 (list (lambda (f g ta t d)
1573 ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1574 (i386:accu-zero?)))))))
1577 ((expr-stmt (pre-dec (p-expr (ident ,name))))
1578 (or (assoc-ref locals name) barf)
1581 ((ident-add info) name -1)
1582 ((ident->accu info) name)
1583 (list (lambda (f g ta t d)
1585 ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1586 ;;(i386:local->accu (local:id (assoc-ref locals name)))
1587 (i386:accu-zero?)))))))
1590 (let* ((test-info ((ast->info info) expr)))
1592 (append (.text test-info)
1593 (list (lambda (f g ta t d)
1596 (i386:accu-zero?)))))
1597 #:globals (.globals test-info))))
1600 (let* ((base ((expr->base info) a))
1601 (empty (clone base #:text '()))
1602 (accu ((expr->accu empty) b)))
1606 (list (lambda (f g ta t d)
1610 (list (lambda (f g ta t d)
1611 (i386:sub-base)))))))
1614 (let* ((base ((expr->base info) a))
1615 (empty (clone base #:text '()))
1616 (accu ((expr->accu empty) b)))
1620 (list (lambda (f g ta t d)
1623 (list (lambda (f g ta t d)
1625 (list (lambda (f g ta t d)
1626 (i386:sub-base)))))))
1629 (let* ((base ((expr->base info) a))
1630 (empty (clone base #:text '()))
1631 (accu ((expr->accu empty) b)))
1635 (list (lambda (f g ta t d)
1638 (list (lambda (f g ta t d)
1640 (list (lambda (f g ta t d)
1643 (i386:xor-zf))))))))
1646 (let* ((base ((expr->base info) a))
1647 (empty (clone base #:text '()))
1648 (accu ((expr->accu empty) b)))
1652 (list (lambda (f g ta t d)
1655 (list (lambda (f g ta t d)
1656 (i386:base-sub)))))))
1658 ;; TODO: byte dinges
1660 (let* ((base ((expr->base info) a))
1661 (empty (clone base #:text '()))
1662 (accu ((expr->accu empty) b)))
1666 (list (lambda (f g ta t d)
1669 (list (lambda (f g ta t d)
1671 (list (lambda (f g ta t d)
1672 (i386:base-sub)))))))
1674 ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1677 (list (lambda (f g ta t d)
1679 (i386:local->accu (local:id (assoc-ref locals a)))
1680 (i386:byte-mem->base)
1681 (i386:local->accu (local:id (assoc-ref locals b)))
1682 (i386:byte-mem->accu)
1683 (i386:byte-sub-base)))))))
1686 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
1687 (let* ((value (cstring->number value))
1688 (type (ident->type info array))
1689 (size (type->size info type)))
1692 ((ident->base info) array)
1693 (list (lambda (f g ta t d)
1695 (i386:value->accu (* size index))
1697 (i386:byte-base-mem->accu)
1698 (i386:base-mem->accu)))))))))
1701 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1702 (let* ((type (ident->type info array))
1703 (size (type->size info type)))
1706 ((ident->base info) index)
1707 (list (lambda (f g ta t d)
1713 (if (= size 12) (i386:accu+base) '())
1714 (i386:accu-shl 2))))))
1715 ((ident->base info) array)
1716 (list (lambda (f g ta t d)
1718 (i386:byte-base-mem->accu)
1719 (i386:base-mem->accu))))))))
1722 (let ((accu ((expr->accu info) expr)))
1724 (append (.text accu) (list (lambda (f g ta t d) (i386:ret)))))))
1727 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1728 (if (.function info)
1729 (clone info #:locals (add-local locals name type 0))
1730 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1733 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1734 (let ((value (cstring->number value)))
1735 (if (.function info)
1736 (let* ((locals (add-local locals name type 0))
1737 (info (clone info #:locals locals)))
1740 ((value->ident info) name value))))
1741 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1744 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1745 (if (not (.function info)) decl-barf0)
1746 (let* ((locals (add-local locals name type 0))
1747 (info (clone info #:locals locals))
1748 (value (char->integer (car (string->list value)))))
1751 ((value->ident info) name value)))))
1754 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1755 (if (not (.function info)) decl-barf1)
1756 (let* ((locals (add-local locals name type 0))
1757 (info (clone info #:locals locals))
1758 (value (- (cstring->number value))))
1761 ((value->ident info) name value)))))
1764 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1765 (if (not (.function info)) decl-barf2)
1766 (let* ((locals (add-local locals name type 0))
1767 (info (clone info #:locals locals)))
1770 ((ident->accu info) local)
1771 ((accu->ident info) name)))))
1774 ;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n"))))))
1775 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1776 (if (not (.function info)) decl-barf3)
1777 (let* ((locals (add-local locals name type 1))
1778 (globals (append globals (list (string->global string))))
1779 (info (clone info #:locals locals #:globals globals)))
1782 (list (lambda (f g ta t d)
1784 (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1785 ((accu->ident info) name)))))
1787 ;; char arena[20000];
1788 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1789 (let ((type (ast->type type)))
1790 (if (.function info)
1792 (let* ((globals (.globals info))
1793 (count (cstring->number count))
1794 (size (type->size info type))
1795 ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1796 (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1797 (globals (append globals (list array))))
1799 #:globals globals)))))
1801 ;;struct scm *g_cells = (struct scm*)arena;
1802 ((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)))))))
1803 ;;(stderr "0TYPE: ~s\n" type)
1804 (if (.function info)
1805 (let* ((locals (add-local locals name type 1))
1806 (info (clone info #:locals locals)))
1809 ((ident->accu info) name)
1810 ((accu->ident info) value)))) ;; FIXME: deref?
1811 (let* ((globals (append globals (list (ident->global name type 1 0))))
1812 (info (clone info #:globals globals)))
1815 ((ident->accu info) name)
1816 ((accu->ident info) value)))))) ;; FIXME: deref?
1819 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1820 ;;(stderr "1TYPE: ~s\n" type)
1821 (if (.function info)
1822 (clone info #:locals (add-local locals name type 0))
1823 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1826 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1827 ;;(stderr "2TYPE: ~s\n" type)
1828 (let ((value (cstring->number value)))
1829 (if (.function info)
1830 (let* ((locals (add-local locals name type 0))
1831 (info (clone info #:locals locals)))
1834 ((value->ident info) name value))))
1835 (let ((globals (append globals (list (ident->global name type 0 value)))))
1836 (clone info #:globals globals)))))
1838 ;; SCM g_stack = 0; // comment
1839 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1840 ((ast->info info) (list-head o (- (length o) 1))))
1843 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1844 ;;(stderr "3TYPE: ~s\n" type)
1845 (if (.function info)
1846 (let* ((locals (add-local locals name type 0))
1847 (info (clone info #:locals locals)))
1850 ((ident->accu info) local)
1851 ((accu->ident info) name))))
1852 (let* ((globals (append globals (list (ident->global name type 0 0))))
1853 (info (clone info #:globals globals)))
1856 ((ident->accu info) local)
1857 ((accu->ident info) name))))))
1859 ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1860 ((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))))
1861 (let* ((locals (add-local locals name type 1))
1862 (info (clone info #:locals locals))
1863 (empty (clone info #:text '()))
1864 (accu ((expr->accu empty) initzer)))
1869 ((accu->ident info) name)
1870 (list (lambda (f g ta t d)
1872 ;;(i386:value->base t)
1874 (i386:value->base ta)
1875 (i386:accu+base)))))
1878 ;; char *p = (char*)g_cells;
1879 ((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)))))))
1880 ;;(stderr "6TYPE: ~s\n" type)
1881 (if (.function info)
1882 (let* ((locals (add-local locals name type 1))
1883 (info (clone info #:locals locals)))
1886 ((ident->accu info) value)
1887 ((accu->ident info) name))))
1888 (let* ((globals (append globals (list (ident->global name type 1 0))))
1889 (here (data-offset name globals))
1890 (there (data-offset value globals)))
1893 #:init (append (.init info)
1894 (list (lambda (functions globals ta t d data)
1896 (list-head data here)
1898 ;;; char *x = arena;
1899 (int->bv32 (+ d (data-offset value globals)))
1901 ;;;(list-head (list-tail data there) 4)
1902 (list-tail data (+ here 4))))))))))
1904 ;; char *p = g_cells;
1905 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1906 ;;(stderr "7TYPE: ~s\n" type)
1907 (let ((type (decl->type type)))
1908 ;;(stderr "0DECL: ~s\n" type)
1909 (if (.function info)
1910 (let* ((locals (add-local locals name type 1))
1911 (info (clone info #:locals locals)))
1914 ((ident->accu info) value)
1915 ((accu->ident info) name))))
1916 (let* ((globals (append globals (list (ident->global name type 1 0))))
1917 (here (data-offset name globals)))
1920 #:init (append (.init info)
1921 (list (lambda (functions globals ta t d data)
1923 (list-head data here)
1925 ;;; char *x = arena;p
1926 (int->bv32 (+ d (data-offset value globals)))
1927 (list-tail data (+ here 4)))))))))))
1930 ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1931 (let ((type (enum->type name fields))
1932 (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1934 #:types (append (.types info) (list type))
1935 #:constants (append constants (.constants info)))))
1938 ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1939 (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1940 ;;(stderr "type: ~a\n" type)
1941 (clone info #:types (append (.types info) (list type)))))
1944 ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
1945 (when (not (equal? op "="))
1946 (stderr "OOOPS0.0: op=~s\n" op)
1948 (let* ((empty (clone info #:text '()))
1949 (base ((expr->base empty) b)))
1953 ((base->ident-address info) name)
1954 ((ident-add info) name 1)))))
1957 ((expr-stmt (assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b))
1958 (when (not (equal? op "="))
1959 (stderr "OOOPS0.0: op=~s\n" op)
1961 (let* ((empty (clone info #:text '()))
1962 (base ((expr->base empty) b)))
1966 ((base->ident-address info) name)
1967 ((ident-add info) name -1)))))
1971 ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
1972 (when (not (equal? op "="))
1973 (stderr "OOOPS0: op=~s\n" op)
1975 (let* ((empty (clone info #:text '()))
1976 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
1977 (base ((expr->base empty) b))
1978 (type (list "struct" "scm")) ;; FIXME
1979 (fields (type->description info type))
1980 (size (type->size info type))
1981 (field-size 4) ;; FIXME:4, not fixed
1982 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) )
1983 (clone info #:text (append text
1986 (list (lambda (f g ta t d)
1987 ;;(i386:byte-base->accu-ref) ;; FIXME: size
1988 (i386:base->accu-address)
1996 ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
1997 (when (and (not (equal? op "="))
1998 (not (equal? op "+="))
1999 (not (equal? op "-=")))
2000 (stderr "OOOPS1: op=~s\n" op)
2002 (let* ((empty (clone info #:text '()))
2003 (base ((expr->base empty) b)))
2004 (clone info #:text (append text
2006 (if (equal? op "=") '()
2007 (append ((ident->accu info) name)
2008 (list (lambda (f g ta t d)
2010 (if (equal? op "+=")
2013 (i386:accu->base))))))
2015 ((base->ident info) name)))))
2018 ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
2019 (when (not (equal? op "="))
2020 (stderr "OOOPS2: op=~s\n" op)
2022 (let* ((empty (clone info #:text '()))
2023 (base ((expr->base empty) b)))
2024 (clone info #:text (append text
2027 ((base->ident-address info) array)))))
2030 ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2031 (when (not (equal? op "="))
2032 (stderr "OOOPS3: op=~s\n" op)
2034 (let* ((index (cstring->number index))
2035 (empty (clone info #:text '()))
2036 (base ((expr->base empty) b))
2037 (type (ident->type info array))
2038 (fields (or (type->description info type) '())) ;; FIXME: struct!
2039 (size (type->size info type))
2040 (count (length fields))
2041 (field-size 4) ;; FIXME:4, not fixed
2042 (ptr (ident->pointer info array)))
2046 (list (lambda (f g ta t d)
2048 (list (lambda (f g ta t d)
2050 (i386:value->base index)
2052 (if (> count 1) (i386:accu+accu) '())
2053 (if (= count 3) (i386:accu+base) '())
2054 (i386:accu-shl 2))))
2055 ((ident->base info) array)
2056 (list (lambda (f g tav t d)
2058 (list (lambda (f g ta t d)
2060 (cond ((equal? array "g_functions") ;; FIXME
2061 (list (lambda (f g ta t d)
2063 (i386:base-address->accu-address)
2066 (i386:base-address->accu-address)
2069 (i386:base-address->accu-address)))))
2070 (else (list (lambda (f g ta t d)
2071 (i386:base->accu-address)))))))))
2074 ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2075 ;;(stderr "pointer_cells4[]: ~s\n" array)
2076 (when (not (equal? op "="))
2077 (stderr "OOOPS4: op=~s\n" op)
2079 (let* ((empty (clone info #:text '()))
2080 (base ((expr->base empty) b))
2081 (type (ident->type info array))
2082 (fields (or (type->description info type) '())) ;; FIXME: struct!
2083 (size (type->size info type))
2084 (count (length fields))
2085 (field-size 4) ;; FIXME:4, not fixed
2086 (ptr (ident->pointer info array)))
2090 (list (lambda (f g ta t d)
2092 ((ident->base info) index)
2093 (list (lambda (f g ta t d)
2096 (if (> count 1) (i386:accu+accu) '())
2097 (if (= count 3) (i386:accu+base) '())
2098 (i386:accu-shl 2))))
2099 ((ident->base info) array)
2100 (list (lambda (f g ta t d)
2102 (list (lambda (f g ta t d)
2104 (cond ((equal? array "g_functions") ;; FIXME
2105 (list (lambda (f g ta t d)
2107 (i386:base-address->accu-address)
2110 (i386:base-address->accu-address)
2113 (i386:base-address->accu-address)))))
2114 (else (list (lambda (f g ta t d)
2115 (i386:base->accu-address)))))))))
2117 ;; g_functions[g_function++] = g_foo;
2118 ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
2119 (when (not (equal? op "="))
2120 (stderr "OOOPS5: op=~s\n" op)
2122 (let* ((empty (clone info #:text '()))
2123 (base ((expr->base empty) b))
2124 (type (ident->type info array))
2125 (fields (or (type->description info type) '())) ;; FIXME: struct!
2126 (size (type->size info type))
2127 (count (length fields))
2128 (field-size 4) ;; FIXME:4, not fixed
2129 (ptr (ident->pointer info array)))
2133 (list (lambda (f g ta t d)
2135 ((ident->base info) index)
2136 (list (lambda (f g ta t d)
2139 (if (> count 1) (i386:accu+accu) '())
2140 (if (= count 3) (i386:accu+base) '())
2141 (i386:accu-shl 2))))
2142 ((ident->base info) array)
2143 (list (lambda (f g ta t d)
2145 (list (lambda (f g ta t d)
2148 (cond ((equal? array "g_functions") ;; FIXME
2149 (list (lambda (f g ta t d)
2151 (i386:base-address->accu-address)
2154 (i386:base-address->accu-address)
2157 (i386:base-address->accu-address)))))
2158 (else (list (lambda (f g ta t d)
2159 (i386:base->accu-address)))))
2160 ((ident-add info) index 1)))))
2164 ;; struct f = {...};
2165 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2166 (let* ((type (decl->type type))
2167 ;;(foo (stderr "1DECL: ~s\n" type))
2168 (fields (type->description info type))
2169 (size (type->size info type))
2170 (field-size 4)) ;; FIXME:4, not fixed
2171 ;;(stderr "7TYPE: ~s\n" type)
2172 (if (.function info)
2173 (let* ((globals (append globals (filter-map initzer->global initzers)))
2174 (locals (let loop ((fields (cdr fields)) (locals locals))
2175 (if (null? fields) locals
2176 (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2177 (locals (add-local locals name type -1))
2178 (info (clone info #:locals locals #:globals globals))
2179 (empty (clone info #:text '())))
2180 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2181 (if (null? fields) info
2182 (let ((offset (* field-size (car fields)))
2183 (initzer (car initzers)))
2184 (loop (cdr fields) (cdr initzers)
2188 ((ident->accu info) name)
2189 (list (lambda (f g ta t d)
2191 (i386:accu->base))))
2192 (.text ((expr->accu empty) initzer))
2193 (list (lambda (f g ta t d)
2194 (i386:accu->base-address+n offset))))))))))
2195 (let* ((globals (append globals (filter-map initzer->global initzers)))
2196 (global (make-global name type -1 (string->list (make-string size #\nul))))
2197 (globals (append globals (list global)))
2198 (here (data-offset name globals))
2199 (info (clone info #:globals globals))
2201 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2202 (if (null? fields) info
2203 (let ((offset (* field-size (car fields)))
2204 (initzer (car initzers)))
2205 (loop (cdr fields) (cdr initzers)
2209 (list (lambda (functions globals ta t d data)
2211 (list-head data (+ here offset))
2212 (initzer->data info functions globals ta t d (car initzers))
2213 (list-tail data (+ here offset field-size)))))))))))))))
2216 ;;char cc = g_cells[c].cdr; ==> generic?
2217 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2218 (let ((type (decl->type type)))
2219 (if (.function info)
2220 (let* ((locals (add-local locals name type 0))
2221 (info (clone info #:locals locals)))
2223 (append (.text ((expr->accu info) initzer))
2224 ((accu->ident info) name))))
2225 (let* ((globals (append globals (list (ident->global name type 1 0))))
2226 (here (data-offset name globals)))
2229 #:init (append (.init info)
2230 (list (lambda (functions globals ta t d data)
2232 (list-head data here)
2233 (initzer->data info functions globals ta t d initzer)
2234 (list-tail data (+ here 4)))))))))))
2237 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2240 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
2243 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2244 (let ((types (.types info)))
2245 (clone info #:types (cons (cons name (assoc-ref types type)) types))))
2247 ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2248 (format (current-error-port) "SKIP: typedef=~s\n" o)
2252 (format (current-error-port) "SKIP: at=~s\n" o)
2256 (format (current-error-port) "SKIP: decl statement=~s\n" o)
2261 (format (current-error-port) "SKIP: statement=~s\n" o)
2265 (define (initzer->data info functions globals ta t d o)
2267 ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2268 ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2269 ((initzer (ref-to (p-expr (ident ,name))))
2270 ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2271 (int->bv32 (+ ta (function-offset name functions))))
2272 ((initzer (p-expr (ident ,name)))
2273 (let ((value (assoc-ref (.constants info) name)))
2275 ((initzer (p-expr (string ,string)))
2276 (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2277 (_ (stderr "initzer->data:SKIP: ~s\n" o)
2281 (define (info->exe info)
2282 (display "dumping elf\n" (current-error-port))
2283 (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2285 (define (.formals o)
2287 ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2288 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2289 (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2292 (define (formal->text n)
2298 (define (formals->text o)
2300 ((param-list . ,formals)
2301 (let ((n (length formals)))
2302 (list (lambda (f g ta t d)
2304 (i386:function-preamble)
2305 (append-map (formal->text n) formals (iota n))
2306 (i386:function-locals))))))
2307 (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2310 (define (formal:ptr o)
2312 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2314 ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2317 (stderr "formal:ptr[~a] => 0\n" o)
2320 (define (formals->locals o)
2322 ((param-list . ,formals)
2323 (let ((n (length formals)))
2324 (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2325 (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2328 (define (function->info info)
2331 ;;(stderr "formals=~a\n" (.formals o))
2332 (let* ((name (.name o))
2333 (text (formals->text (.formals o)))
2334 (locals (formals->locals (.formals o))))
2335 (format (current-error-port) "compiling ~a\n" name)
2336 ;;(stderr "locals=~a\n" locals)
2337 (let loop ((statements (.statements o))
2338 (info (clone info #:locals locals #:function (.name o) #:text text)))
2339 (if (null? statements) (clone info
2341 #:functions (append (.functions info) (list (cons name (.text info)))))
2342 (let* ((statement (car statements)))
2343 (loop (cdr statements)
2344 ((ast->info info) (car statements)))))))))
2346 (define (ast-list->info info)
2348 (let loop ((elements elements) (info info))
2349 (if (null? elements) info
2350 (loop (cdr elements) ((ast->info info) (car elements)))))))
2353 (let* ((ast (mescc))
2355 #:functions i386:libc
2356 #:types i386:type-alist))
2357 (ast (append libc ast))
2358 (info ((ast->info info) ast))
2359 (info ((ast->info info) _start)))