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 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)))
51 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
56 "__NYACC__=1" ;; REMOVEME
65 ,(string-append "DATADIR=\"" %datadir "\"")
66 ,(string-append "DOCDIR=\"" %docdir "\"")
67 ,(string-append "PREFIX=\"" %prefix "\"")
68 ,(string-append "MODULEDIR=\"" %moduledir "\"")
69 ,(string-append "VERSION=\"" %version "\"")
74 (write-char (cond ((char? x) x)
75 ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
76 ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
78 (stderr "write-any: proc: ~a\n" x)
79 (stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
81 (else (stderr "write-any: ~a\n" x) barf))))
83 (define (ast:function? o)
84 (and (pair? o) (eq? (car o) 'fctn-defn)))
88 ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
89 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
90 ((param-decl _ (param-declr (ident ,name))) name)
91 ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
92 ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
94 (format (current-error-port) "SKIP: .name =~a\n" o))))
98 ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
99 ((param-decl ,type _) type)
101 (format (current-error-port) "SKIP: .type =~a\n" o))))
103 (define (.statements o)
105 ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
106 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
108 (define <info> '<info>)
109 (define <types> '<types>)
110 (define <constants> '<constants>)
111 (define <functions> '<functions>)
112 (define <globals> '<globals>)
113 (define <init> '<init>)
114 (define <locals> '<locals>)
115 (define <function> '<function>)
116 (define <text> '<text>)
118 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()))
122 (cons <constants> constants)
123 (cons <functions> functions)
124 (cons <globals> globals)
126 (cons <locals> locals)
127 (cons <function> function)
128 (cons <text> text)))))
132 ((<info> . ,alist) (assq-ref alist <types>))))
134 (define (.constants o)
136 ((<info> . ,alist) (assq-ref alist <constants>))))
138 (define (.functions o)
140 ((<info> . ,alist) (assq-ref alist <functions>))))
144 ((<info> . ,alist) (assq-ref alist <globals>))))
148 ((<info> . ,alist) (assq-ref alist <init>))))
152 ((<info> . ,alist) (assq-ref alist <locals>))))
154 (define (.function o)
156 ((<info> . ,alist) (assq-ref alist <function>))))
160 ((<info> . ,alist) (assq-ref alist <text>))))
163 (and (pair? o) (eq? (car o) <info>)))
165 (define (clone o . rest)
167 (let ((types (.types o))
168 (constants (.constants o))
169 (functions (.functions o))
170 (globals (.globals o))
173 (function (.function o))
178 (constants constants)
179 (functions functions)
185 (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text))))))
187 (define (push-global globals)
191 (i386:push-global (+ (data-offset o g) d))))))
193 (define (push-local locals)
197 (i386:push-local (local:id o))))))
199 (define (push-global-address globals)
203 (i386:push-global-address (+ (data-offset o g) d))))))
205 (define (push-local-address locals)
209 (i386:push-local-address (local:id o))))))
211 (define push-global-de-ref push-global)
213 (define (push-local-de-ref locals)
217 (i386:push-local-de-ref (local:id o))))))
219 (define (string->global string)
220 (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
222 (define (ident->global name type pointer value)
223 (make-global name type pointer (int->bv32 value)))
225 (define (make-local name type pointer id)
226 (cons name (list type pointer id)))
227 (define local:type car)
228 (define local:pointer cadr)
229 (define local:id caddr)
231 (define (push-ident info)
233 (let ((local (assoc-ref (.locals info) o)))
234 (if local ((push-local (.locals info)) local)
235 (let ((global (assoc-ref (.globals info) o)))
237 ((push-global (.globals info)) o) ;; FIXME: char*/int
238 (let ((constant (assoc-ref (.constants info) o)))
240 (list (lambda (f g ta t d)
242 (i386:value->accu constant)
244 TODO:push-function))))))))
246 (define (push-ident-address info)
248 (let ((local (assoc-ref (.locals info) o)))
249 (if local ((push-local-address (.locals info)) local)
250 ((push-global-address (.globals info)) o)))))
252 (define (push-ident-de-ref info)
254 (let ((local (assoc-ref (.locals info) o)))
255 (if local ((push-local-de-ref (.locals info)) local)
256 ((push-global-de-ref (.globals info)) o)))))
258 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
260 (let ((text (.text info)))
261 ;;(stderr "expr->arg o=~s\n" o)
263 ((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 ((neg (p-expr (fixed ,value)))
273 (let ((value (- (cstring->number value))))
274 (clone info #:text (append text
278 (i386:value->accu value)
279 (i386:push-accu))))))))
281 ((p-expr (string ,string))
282 (clone info #:text (append text ((push-global-address info) (add-s:-prefix string)))))
284 ((p-expr (ident ,name))
285 (clone info #:text (append text ((push-ident info) name))))
288 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
289 (let* ((index (cstring->number index))
290 (type (ident->type info array))
291 (size (type->size info type)))
294 ((ident->base info) array)
298 (i386:value->accu (* size index))
300 (i386:byte-base-mem->accu)
301 (i386:base-mem->accu))
302 (i386:push-accu))))))))
305 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
306 (let* ((type (ident->type info array))
307 (size (type->size info type)))
308 (clone info #:text (append text
309 ((ident->base info) index)
310 (list (lambda (f g ta t d)
316 (if (= size 12) (i386:accu+base)
318 ((ident->base info) array)
319 (list (lambda (f g ta t d)
321 (i386:byte-base-mem->accu)
322 (i386:base-mem->accu))))
325 (i386:push-accu)))))))
327 ((de-ref (p-expr (ident ,name)))
328 (clone info #:text (append text ((push-ident-de-ref info) name))))
330 ((ref-to (p-expr (ident ,name)))
331 (clone info #:text (append text ((push-ident-address info) name))))
335 (let* (;;(empty (clone info #:text '()))
336 ;;(info ((ast->info empty) o))
337 (info ((ast->info info) o))
343 (i386:push-accu)))))))
347 (let* (;;(empty (clone info #:text '()))
348 ;;(expr ((expr->accu empty) `(d-sel ,@d-sel)))
349 (expr ((expr->accu info) `(d-sel ,@d-sel)))
353 (list (lambda (f g ta t d)
354 (i386:push-accu)))))))
357 ((p-expr (char ,char))
358 (let ((char (char->integer (car (string->list char)))))
361 (list (lambda (f g ta t d)
363 (i386:value->accu char)
364 (i386:push-accu)))))))
368 ;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
370 ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
371 (abs-declr (pointer)))
373 ((expr->arg info) cast))
376 ;; (stderr "catch: expr->arg=~s\n" o)
377 (let* ((info ((expr->accu info) o))
381 (list (lambda (f g ta t d)
384 (i386:push-accu))))))))
387 (stderr "SKIP: expr->arg=~s\n" o)
391 ;; FIXME: see ident->base
392 (define (ident->accu info)
394 (let ((local (assoc-ref (.locals info) o))
395 (global (assoc-ref (.globals info) o))
396 (constant (assoc-ref (.constants info) o)))
397 ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
398 ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
399 ;; (stderr "globals: ~a\n" (.globals info))
400 ;; (if (and (not global) (not (local:id local)))
401 ;; (stderr "globals: ~a\n" (map car (.globals info))))
403 (let* ((ptr (local:pointer local))
404 (type (ident->type info o))
405 (size (and type (type->size info type))))
406 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
407 ;;(stderr "type: ~s\n" type)
408 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
409 ;;(stderr "locals: ~s\n" locals)
411 ((-1) (list (lambda (f g ta t d)
412 (i386:local-ptr->accu (local:id local)))))
413 ((1) (list (lambda (f g ta t d)
414 (i386:local->accu (local:id local)))))
416 (list (lambda (f g ta t d)
418 (i386:byte-local->accu (local:id local))
419 (i386:local->accu (local:id local))))))))
421 (let ((ptr (ident->pointer info o)))
422 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
424 ((-1) (list (lambda (f g ta t d)
425 (i386:global->accu (+ (data-offset o g) d)))))
426 (else (list (lambda (f g ta t d)
427 (i386:global-address->accu (+ (data-offset o g) d)))))))
429 (list (lambda (f g ta t d)
430 (i386:value->accu constant)))
431 (list (lambda (f g ta t d)
432 (i386:global->accu (+ ta (function-offset o f)))))))))))
434 (define (value->accu v)
435 (list (lambda (f g ta t d)
436 (i386:value->accu v))))
438 (define (accu->ident info)
440 (let ((local (assoc-ref (.locals info) o)))
442 (list (lambda (f g ta t d)
443 (i386:accu->local (local:id local))))
444 (list (lambda (f g ta t d)
445 (i386:accu->global (+ (data-offset o g) d))))))))
447 (define (base->ident info)
449 (let ((local (assoc-ref (.locals info) o)))
451 (list (lambda (f g ta t d)
452 (i386:base->local (local:id local))))
453 (list (lambda (f g ta t d)
454 (i386:base->global (+ (data-offset o g) d))))))))
456 (define (base->ident-address info)
458 (let ((local (assoc-ref (.locals info) o)))
460 (list (lambda (f g ta t d)
462 (i386:local->accu (local:id local))
463 (i386:byte-base->accu-address))))
464 TODO:base->ident-address-global))))
466 (define (value->ident info)
468 (let ((local (assoc-ref (.locals info) o)))
470 (list (lambda (f g ta t d)
471 (i386:value->local (local:id local) value)))
472 (list (lambda (f g ta t d)
473 (i386:value->global (+ (data-offset o g) d) value)))))))
475 (define (ident-add info)
477 (let ((local (assoc-ref (.locals info) o)))
479 (list (lambda (f g ta t d)
480 (i386:local-add (local:id local) n)))
481 (list (lambda (f g ta t d)
482 (i386:global-add (+ (data-offset o g) d) n)))))))
484 ;; FIXME: see ident->accu
485 (define (ident->base info)
487 (let ((local (assoc-ref (.locals info) o)))
488 ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
490 (let* ((ptr (local:pointer local))
491 (type (ident->type info o))
492 (size (and type (type->size info type))))
494 ((-1) (list (lambda (f g ta t d)
495 (i386:local-ptr->base (local:id local)))))
496 ((1) (list (lambda (f g ta t d)
497 (i386:local->base (local:id local)))))
499 (list (lambda (f g ta t d)
501 (i386:byte-local->base (local:id local))
502 (i386:local->base (local:id local))))))))
503 (let ((global (assoc-ref (.globals info) o) ))
505 (let ((ptr (ident->pointer info o)))
506 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
508 ((-1) (list (lambda (f g ta t d)
509 (i386:global->base (+ (data-offset o g) d)))))
510 (else (list (lambda (f g ta t d)
511 (i386:global-address->base (+ (data-offset o g) d)))))))
512 (let ((constant (assoc-ref (.constants info) o)))
514 (list (lambda (f g ta t d)
515 (i386:value->base constant)))
516 (list (lambda (f g ta t d)
517 (i386:global->base (+ ta (function-offset o f)))))))))))))
519 (define (expr->accu info)
521 (let ((text (.text info))
522 (locals (.locals info))
523 (globals (.globals info)))
524 ;;(stderr "expr->accu o=~a\n" o)
526 ((p-expr (string ,string))
527 (clone info #:text (append text (list (lambda (f g ta t d)
528 ;;(stderr "OFF[~a]: ~a\n" string (data-offset string globals))
529 ;;(stderr "globals: ~s\n" (map car globals))
530 (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
531 ((p-expr (fixed ,value))
532 (clone info #:text (append text (value->accu (cstring->number value)))))
533 ((p-expr (ident ,name))
534 (clone info #:text (append text ((ident->accu info) name))))
535 ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
536 ((not (fctn-call . _)) ((ast->info info) o))
537 ((neg (p-expr (fixed ,value)))
538 (clone info #:text (append text (value->accu (- (cstring->number value))))))
540 ((initzer ,initzer) ((expr->accu info) initzer))
541 ((ref-to (p-expr (ident ,name)))
544 ((ident->accu info) name))))
546 ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
547 (let* ((type (list "struct" name))
548 (fields (or (type->description info type) '()))
549 (size (type->size info type)))
552 (list (lambda (f g ta t d)
554 (i386:value->accu size))))))))
558 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
559 (let* ((index (cstring->number index))
560 (type (ident->type info array))
561 (size (type->size info type)))
564 ((ident->base info) array)
565 (list (lambda (f g ta t d)
567 (i386:value->accu (* size index))
569 ((1) (i386:byte-base-mem->accu))
570 ((4) (i386:base-mem->accu))
571 (else (i386:accu+base))))))))))
575 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
576 (let* ((type (ident->type info array))
577 (size (type->size info type)))
578 (clone info #:text (append text
579 ((ident->base info) index)
580 (list (lambda (f g ta t d)
586 (if (= size 12) (i386:accu+base) '())
587 (i386:accu-shl 2))))))
588 ((ident->base info) array)
589 (list (lambda (f g ta t d)
591 ((1) (i386:byte-base-mem->accu))
592 ((4) (i386:base-mem->accu))
593 (else (i386:accu+base)))))))))
596 ((d-sel (ident ,field) (p-expr (ident ,array)))
597 (let* ((type (ident->type info array))
598 (fields (type->description info type))
599 (field-size 4) ;; FIXME:4, not fixed
600 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
604 ((ident->accu info) array)
605 (list (lambda (f g ta t d)
606 (i386:mem+n->accu offset)))))))
609 ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
610 (let* ((type (ident->type info array))
611 (fields (or (type->description info type) '()))
612 (size (type->size info type))
613 (count (length fields))
614 (field-size 4) ;; FIXME:4, not fixed
615 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
616 (index (cstring->number index))
620 (list (lambda (f g ta t d)
622 (i386:value->base index)
624 (if (> count 1) (i386:accu+accu) '())
625 (if (= count 3) (i386:accu+base) '())
627 ((ident->base info) array)
628 (list (lambda (f g ta t d)
629 (i386:base-mem+n->accu offset)))))))
632 ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
633 (let* ((type (ident->type info array))
634 (fields (or (type->description info type) '()))
635 (size (type->size info type))
636 (count (length fields))
637 (field-size 4) ;; FIXME:4, not fixed
638 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
642 ((ident->base info) index)
643 (list (lambda (f g ta t d)
646 (if (> count 1) (i386:accu+accu) '())
647 (if (= count 3) (i386:accu+base) '())
649 ((ident->base info) array)
650 (list (lambda (f g ta t d)
651 (i386:base-mem+n->accu offset)))))))
653 ;; g_functions[g_cells[fn].cdr].arity
654 ;; INDEX0: g_cells[fn].cdr
656 ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
657 ;;((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)))))
658 ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
659 (let* ((empty (clone info #:text '()))
660 (index ((expr->accu empty) index))
661 (type (ident->type info array))
662 (fields (or (type->description info type) '()))
663 (size (type->size info type))
664 (count (length fields))
665 (field-size 4) ;; FIXME:4, not fixed
666 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
668 (stderr "no field:~a\n" field)
670 (offset (* field-size (1- (length rest))))
675 (list (lambda (f g ta t d)
678 (if (> count 1) (i386:accu+accu) '())
679 (if (= count 3) (i386:accu+base) '())
681 ((ident->base info) array)
682 (list (lambda (f g ta t d)
683 (i386:base-mem+n->accu offset)))))))
685 ;;; FIXME: FROM INFO ...only zero?!
686 ((p-expr (fixed ,value))
687 (let ((value (cstring->number value)))
690 (list (lambda (f g ta t d)
691 (i386:value->accu value)))))))
693 ((p-expr (char ,char))
694 (let ((char (char->integer (car (string->list char)))))
697 (list (lambda (f g ta t d)
698 (i386:value->accu char)))))))
700 ((p-expr (ident ,name))
703 ((ident->accu info) name))))
705 ((de-ref (p-expr (ident ,name)))
706 (let* ((type (ident->type info name))
707 (size (and type (type->size info type))))
710 ((ident->accu info) name)
711 (list (lambda (f g ta t d)
713 (i386:byte-mem->accu)
714 (i386:mem->accu))))))))
716 ;; GRR --> info again??!?
718 ((ast->info info) `(expr-stmt ,o)))
720 ((cond-expr . ,cond-expr)
721 ((ast->info info) `(expr-stmt ,o)))
724 ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
725 ((post-inc (p-expr (ident ,name)))
728 ((ident->accu info) name)
729 ((ident-add info) name 1))))
731 ;; GRR --> info again??!?
732 ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
733 ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
734 ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
735 ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
737 ((add (p-expr (ident ,name)) ,b)
738 (let* ((empty (clone info #:text '()))
739 (base ((expr->base empty) b)))
743 ((ident->accu info) name)
744 (list (lambda (f g ta t d)
745 (i386:accu+base)))))))
748 (let* ((empty (clone info #:text '()))
749 (accu ((expr->accu empty) a))
750 (base ((expr->base empty) b)))
755 (list (lambda (f g ta t d)
756 (i386:accu+base)))))))
759 (let* ((empty (clone info #:text '()))
760 (accu ((expr->accu empty) a))
761 (base ((expr->base empty) b)))
766 (list (lambda (f g ta t d)
767 (i386:accu-base)))))))
770 (let* ((empty (clone info #:text '()))
771 (accu ((expr->accu empty) a))
772 (base ((expr->base empty) b)))
777 (list (lambda (f g ta t d)
778 (i386:accu-or-base)))))))
781 (let* ((empty (clone info #:text '()))
782 (accu ((expr->accu empty) a))
783 (base ((expr->base empty) b)))
788 (list (lambda (f g ta t d)
789 (i386:accu<<base)))))))
792 (let* ((empty (clone info #:text '()))
793 (accu ((expr->accu empty) a))
794 (base ((expr->base empty) b)))
799 (list (lambda (f g ta t d)
800 (i386:accu>>base)))))))
803 (let* ((empty (clone info #:text '()))
804 (accu ((expr->accu empty) a))
805 (base ((expr->base empty) b)))
810 (list (lambda (f g ta t d)
811 (i386:accu/base)))))))
814 (let* ((empty (clone info #:text '()))
815 (accu ((expr->accu empty) a))
816 (base ((expr->base empty) b)))
818 (append text ;;FIXME:empty
821 (list (lambda (f g ta t d)
822 (i386:accu%base)))))))
825 (let* ((empty (clone info #:text '()))
826 (accu ((expr->accu empty) a))
827 (base ((expr->base empty) b)))
832 (list (lambda (f g ta t d)
833 (i386:accu*base)))))))
835 ;; FIXME: c/p ast->info
837 (let* ((base ((expr->base info) a))
838 (empty (clone base #:text '()))
839 (accu ((expr->accu empty) b)))
842 (list (lambda (f g ta t d)
845 (list (lambda (f g ta t d)
847 (list (lambda (f g ta t d)
848 (i386:sub-base)))))))
850 ;; FIXME: c/p ast->info
852 (let* ((base ((expr->base info) a))
853 (empty (clone base #:text '()))
854 (accu ((expr->accu empty) b)))
858 (list (lambda (f g ta t d)
859 (i386:base-sub)))))))
861 ;; FIXME: ...c/p ast->info
862 ((neg (p-expr (ident ,name)))
863 (clone info #:text (append text
864 ((ident->base info) name)
865 (list (lambda (f g ta t d)
866 (i386:value->accu 0)))
867 (list (lambda (f g ta t d)
870 ;;((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"))))))
872 ((expr->accu info) o))
874 ((assn-expr (p-expr (ident ,name)) ,op ,expr)
875 (let ((info ((ast->info info) o)))
876 (clone info #:text (append (.text info)
877 ((ident->accu info) name)))))
880 (format (current-error-port) "SKIP: expr->accu=~s\n" o)
884 (define (expr->base info)
886 (let ((info ((expr->accu info) o)))
889 (list (lambda (f g ta t d)
892 (list (lambda (f g ta t d)
895 (i386:pop-accu)))))))))
897 (define (expr->accu* info)
900 ;;(stderr "expr->accu* o=~s\n" o)
902 ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
903 (let* ((type (ident->type info array))
904 (fields (or (type->description info type) '()))
905 (size (type->size info type))
906 (count (length fields))
907 (field-size 4) ;; FIXME:4, not fixed
908 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
909 (index (cstring->number index))
913 (list (lambda (f g ta t d)
915 (i386:value->base index)
917 (if (> count 1) (i386:accu+accu) '())
918 (if (= count 3) (i386:accu+base) '())
920 ;; de-ref: g_cells, non: arena
921 ;;((ident->base info) array)
922 ((ident->base info) array)
923 (list (lambda (f g ta t d)
926 (i386:accu+value offset))))))))
929 ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
930 (let* ((type (ident->type info array))
931 (fields (or (type->description info type) '()))
932 (size (type->size info type))
933 (count (length fields))
934 (field-size 4) ;; FIXME:4, not fixed
935 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
939 ((ident->base info) index)
940 (list (lambda (f g ta t d)
943 (if (> count 1) (i386:accu+accu) '())
944 (if (= count 3) (i386:accu+base) '())
946 ;; de-ref: g_cells, non: arena
947 ;;((ident->base info) array)
948 ((ident->base info) array)
949 (list (lambda (f g ta t d)
952 (i386:accu+value offset))))))))
954 ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
955 ((d-sel (ident ,field) (p-expr (ident ,name)))
956 (let* ((type (ident->type info name))
957 (fields (or (type->description info type) '()))
958 (field-size 4) ;; FIXME
959 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
963 ((ident->accu info) name)
964 (list (lambda (f g ta t d)
965 (i386:accu+value offset)))))))
968 (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
973 (define (ident->constant name value)
976 (define (make-type name type size description)
977 (cons name (list type size description)))
979 (define (enum->type name fields)
980 (make-type name 'enum 4 fields))
982 (define (struct->type name fields)
983 (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
985 (define (decl->type o)
987 ((fixed-type ,type) type)
988 ((struct-ref (ident ,name)) (list "struct" name))
989 ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
990 (list "struct" name)) ;; FIXME
991 ((typename ,name) name)
993 (stderr "SKIP: decl type=~s\n" o)
997 (define (expr->global o)
999 ((p-expr (string ,string)) (string->global string))
1002 (define (initzer->global o)
1004 ((initzer ,initzer) (expr->global initzer))
1007 (define (byte->hex o)
1008 (string->number (string-drop o 2) 16))
1010 (define (asm->hex o)
1011 (let ((prefix ".byte "))
1012 (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
1013 (let ((s (string-drop o (string-length prefix))))
1014 (map byte->hex (string-split s #\space))))))
1016 (define (case->jump-info info)
1018 (list (lambda (f g ta t d) (i386:Xjump n))))
1020 (list (lambda (f g ta t d) (i386:Xjump-nz n))))
1021 (define (statement->info info body-length)
1024 ((break) (clone info #:text (append (.text info) (jump body-length)
1027 ((ast->info info) o)))))
1030 ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
1031 (lambda (body-length)
1033 (define (test->text value clause-length)
1034 (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1035 (jump-nz clause-length)))
1036 (let* ((value (assoc-ref (.constants info) constant))
1038 (clone info #:text (append (.text info) (test->text value 0))))
1039 (text-length (length (.text test-info)))
1040 (clause-info (let loop ((elements elements) (info test-info))
1041 (if (null? elements) info
1042 (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1043 (clause-text (list-tail (.text clause-info) text-length))
1044 (clause-length (length (text->list clause-text))))
1045 (clone info #:text (append
1047 (test->text value clause-length)
1049 #:globals (.globals clause-info)))))
1051 ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
1052 (lambda (body-length)
1054 (define (test->text value clause-length)
1055 (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
1056 (jump-nz clause-length)))
1057 (let* ((value (cstring->number value))
1059 (clone info #:text (append (.text info) (test->text value 0))))
1060 (text-length (length (.text test-info)))
1061 (clause-info (let loop ((elements elements) (info test-info))
1062 (if (null? elements) info
1063 (loop (cdr elements) ((statement->info info body-length) (car elements))))))
1064 (clause-text (list-tail (.text clause-info) text-length))
1065 (clause-length (length (text->list clause-text))))
1066 (clone info #:text (append
1068 (test->text value clause-length)
1070 #:globals (.globals clause-info)))))
1072 ((case (neg (p-expr (fixed ,value))) ,statement)
1073 ((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
1075 ((default (compd-stmt (block-item-list . ,elements)))
1076 (lambda (body-length)
1077 (let ((text-length (length (.text info))))
1078 (let loop ((elements elements) (info info))
1079 (if (null? elements) info
1080 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
1082 ((case (p-expr (ident ,constant)) ,statement)
1083 ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
1085 ((case (p-expr (fixed ,value)) ,statement)
1086 ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
1088 ((default ,statement)
1089 ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
1091 (_ (stderr "no case match: ~a\n" o) barf)
1094 (define (test->jump->info info)
1095 (define (jump type . test)
1097 (let* ((text (.text info))
1098 (info (clone info #:text '()))
1099 (info ((ast->info info) o))
1100 (jump-text (lambda (body-length)
1101 (list (lambda (f g ta t d) (type body-length))))))
1102 (lambda (body-length)
1106 (if (null? test) '() (car test))
1107 (jump-text body-length)))))))
1111 ;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
1112 ;; ((lt ,a ,b) ((jump i386:Xjump-nc) o)) ; jae
1113 ;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
1114 ;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
1116 ((le ,a ,b) ((jump i386:Xjump-g) o))
1117 ((lt ,a ,b) ((jump i386:Xjump-ge) o))
1118 ((ge ,a ,b) ((jump i386:Xjump-g) o))
1119 ((gt ,a ,b) ((jump i386:Xjump-ge) o))
1121 ((ne ,a ,b) ((jump i386:Xjump-nz) o))
1122 ((eq ,a ,b) ((jump i386:Xjump-nz) o))
1123 ((not _) ((jump i386:Xjump-z) o))
1125 (let* ((text (.text info))
1126 (info (clone info #:text '()))
1128 (a-jump ((test->jump->info info) a))
1129 (a-text (.text (a-jump 0)))
1130 (a-length (length (text->list a-text)))
1132 (b-jump ((test->jump->info info) b))
1133 (b-text (.text (b-jump 0)))
1134 (b-length (length (text->list b-text))))
1136 (lambda (body-length)
1139 (.text (a-jump (+ b-length body-length)))
1140 (.text (b-jump body-length)))))))
1142 (let* ((text (.text info))
1143 (info (clone info #:text '()))
1145 (a-jump ((test->jump->info info) a))
1146 (a-text (.text (a-jump 0)))
1147 (a-length (length (text->list a-text)))
1149 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1150 (jump-length (length (text->list jump-text)))
1152 (b-jump ((test->jump->info info) b))
1153 (b-text (.text (b-jump 0)))
1154 (b-length (length (text->list b-text)))
1156 (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
1158 (lambda (body-length)
1161 (.text (a-jump jump-length))
1163 (.text (b-jump body-length)))))))
1165 ((array-ref . _) ((jump i386:jump-byte-z
1166 (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1168 ((de-ref _) ((jump i386:jump-byte-z
1169 (list (lambda (f g ta t d) (i386:accu-zero?)))) o))
1171 ((assn-expr (p-expr (ident ,name)) ,op ,expr)
1174 ((ident->accu info) name)
1175 (list (lambda (f g ta t d) (i386:accu-zero?))))) o))
1177 (_ ((jump i386:Xjump-z (list (lambda (f g ta t d) (i386:accu-zero?)))) o)))))
1179 (define (cstring->number s)
1180 (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
1181 ((string-prefix? "0" s) (string->number s 8))
1182 (else (string->number s))))
1184 (define (struct-field o)
1186 ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
1187 (comp-declr-list (comp-declr (ident ,name))))
1189 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
1191 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
1193 ((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)))))))))
1194 (cons type name)) ;; FIXME function / int
1195 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
1196 (cons type name)) ;; FIXME: ptr/char
1197 (_ (stderr "struct-field: no match: ~s\n" o) barf)))
1199 (define (ast->type o)
1203 ((struct-ref (ident ,type))
1204 (list "struct" type))
1205 (_ (stderr "SKIP: type=~s\n" o)
1208 (define i386:type-alist
1209 '(("char" . (builtin 1 #f))
1210 ("int" . (builtin 4 #f))))
1212 (define (type->size info o)
1213 ;;(stderr "types=~s\n" (.types info))
1214 ;;(stderr "type->size o=~s => ~s\n" o (cadr (assoc-ref (.types info) o)))
1216 ((decl-spec-list (type-spec (fixed-type ,type)))
1217 (type->size info type))
1218 ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1219 (type->size info type))
1220 (_ (let ((type (assoc-ref (.types info) o)))
1221 (if type (cadr type)
1223 (stderr "***TYPE NOT FOUND**: o=~s\n" o)
1227 (define (ident->decl info o)
1228 ;; (stderr "ident->decl o=~s\n" o)
1229 ;; (stderr " types=~s\n" (.types info))
1230 ;; (stderr " local=~s\n" (assoc-ref (.locals info) o))
1231 ;; (stderr " global=~s\n" (assoc-ref (.globals info) o))
1232 (or (assoc-ref (.locals info) o)
1233 (assoc-ref (.globals info) o)
1235 (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1236 (assoc-ref (.functions info) o))))
1238 (define (ident->type info o)
1239 (and=> (ident->decl info o) car))
1241 (define (ident->pointer info o)
1242 (let ((local (assoc-ref (.locals info) o)))
1243 (if local (local:pointer local)
1244 (or (and=> (ident->decl info o) global:pointer) 0))))
1246 (define (type->description info o)
1247 ;; (stderr "type->description =~s\n" o)
1248 ;; (stderr "types=~s\n" (.types info))
1249 ;; (stderr "type->description o=~s ==> ~s\n" o (caddr (assoc-ref (.types info) o)))
1250 ;; (stderr " assoc ~a\n" (assoc-ref (.types info) o))
1252 ((decl-spec-list (type-spec (fixed-type ,type)))
1253 (type->description info type))
1254 ((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
1255 (type->description info type))
1256 (_ (caddr (assoc-ref (.types info) o)))))
1258 (define (local? o) ;; formals < 0, locals > 0
1259 (positive? (local:id o)))
1261 (define (ast->info info)
1263 (let ((globals (.globals info))
1264 (locals (.locals info))
1265 (constants (.constants info))
1266 (text (.text info)))
1267 (define (add-local locals name type pointer)
1268 (let* ((id (1+ (length (filter local? (map cdr locals)))))
1269 (locals (cons (make-local name type pointer id) locals)))
1272 ;; (stderr "\n ast->info=~s\n" o)
1273 ;; (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)))
1274 ;; (stderr " text=~a\n" text)
1275 ;; (stderr " info=~a\n" info)
1276 ;; (stderr " globals=~a\n" globals)
1278 (((trans-unit . _) . _)
1279 ((ast-list->info info) o))
1280 ((trans-unit . ,elements)
1281 ((ast-list->info info) elements))
1282 ((fctn-defn . _) ((function->info info) o))
1283 ((comment . _) info)
1284 ((cpp-stmt (define (name ,name) (repl ,value)))
1287 ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1290 ;; FIXME: expr-stmt wrapper?
1293 ((assn-expr . ,assn-expr)
1294 ((ast->info info) `(expr-stmt ,o)))
1297 (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1300 ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1302 ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1303 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1304 (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1305 (let* ((globals (append globals (filter-map expr->global expr-list)))
1306 (info (clone info #:globals globals))
1307 (text-length (length text))
1308 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1309 (if (null? expressions) info
1310 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1311 (text (.text args-info))
1312 (n (length expr-list)))
1313 (if (and (not (assoc-ref locals name))
1314 (assoc-ref (.functions info) name))
1315 (clone args-info #:text
1317 (list (lambda (f g ta t d)
1318 (i386:call f g ta t d (+ t (function-offset name f)) n))))
1320 (let* ((empty (clone info #:text '()))
1321 (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1322 (clone args-info #:text
1325 (list (lambda (f g ta t d)
1326 (i386:call-accu f g ta t d n))))
1327 #:globals globals))))))
1329 ;;((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))))
1330 ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1331 (let* ((globals (append globals (filter-map expr->global expr-list)))
1332 (info (clone info #:globals globals))
1333 (text-length (length text))
1334 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1335 (if (null? expressions) info
1336 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1337 (text (.text args-info))
1338 (n (length expr-list))
1339 (empty (clone info #:text '()))
1340 (accu ((expr->accu empty) function)))
1344 (list (lambda (f g ta t d)
1345 (i386:call-accu f g ta t d n))))
1346 #:globals globals)))
1349 (let* ((text-length (length text))
1351 (test-jump->info ((test->jump->info info) test))
1352 (test+jump-info (test-jump->info 0))
1353 (test-length (length (.text test+jump-info)))
1355 (body-info ((ast->info test+jump-info) body))
1356 (text-body-info (.text body-info))
1357 (body-text (list-tail text-body-info test-length))
1358 (body-length (length (text->list body-text)))
1360 (text+test-text (.text (test-jump->info body-length)))
1361 (test-text (list-tail text+test-text text-length)))
1367 #:globals (.globals body-info))))
1369 ((if ,test ,then ,else)
1370 (let* ((text-length (length text))
1372 (test-jump->info ((test->jump->info info) test))
1373 (test+jump-info (test-jump->info 0))
1374 (test-length (length (.text test+jump-info)))
1376 (then-info ((ast->info test+jump-info) then))
1377 (text-then-info (.text then-info))
1378 (then-text (list-tail text-then-info test-length))
1379 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1380 (then-jump-length (length (text->list then-jump-text)))
1381 (then-length (+ (length (text->list then-text)) then-jump-length))
1383 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1384 (else-info ((ast->info then+jump-info) else))
1385 (text-else-info (.text else-info))
1386 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1387 (else-length (length (text->list else-text)))
1389 (text+test-text (.text (test-jump->info then-length)))
1390 (test-text (list-tail text+test-text text-length))
1391 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1399 #:globals (append (.globals then-info)
1400 (list-tail (.globals else-info) (length globals))))))
1402 ((expr-stmt (cond-expr ,test ,then ,else))
1403 (let* ((text-length (length text))
1405 (test-jump->info ((test->jump->info info) test))
1406 (test+jump-info (test-jump->info 0))
1407 (test-length (length (.text test+jump-info)))
1409 (then-info ((ast->info test+jump-info) then))
1410 (text-then-info (.text then-info))
1411 (then-text (list-tail text-then-info test-length))
1412 (then-length (length (text->list then-text)))
1414 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1415 (jump-length (length (text->list jump-text)))
1417 (test+then+jump-info
1419 #:text (append (.text then-info) jump-text)))
1421 (else-info ((ast->info test+then+jump-info) else))
1422 (text-else-info (.text else-info))
1423 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1424 (else-length (length (text->list else-text)))
1426 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1427 (test-text (list-tail text+test-text text-length))
1428 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1436 #:globals (.globals else-info))))
1438 ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1439 (let* ((expr ((expr->accu info) expr))
1440 (empty (clone info #:text '()))
1441 (case-infos (map (case->jump-info empty) cases))
1442 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1443 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1444 (if (null? cases) info
1445 (let ((c-j ((case->jump-info info) (car cases))))
1446 (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1449 ((for ,init ,test ,step ,body)
1450 (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1452 (info ((ast->info info) init))
1454 (init-text (.text info))
1455 (init-locals (.locals info))
1456 (info (clone info #:text '()))
1458 (body-info ((ast->info info) body))
1459 (body-text (.text body-info))
1460 (body-length (length (text->list body-text)))
1462 (step-info ((ast->info info) `(expr-stmt ,step)))
1463 (step-text (.text step-info))
1464 (step-length (length (text->list step-text)))
1466 (test-jump->info ((test->jump->info info) test))
1467 (test+jump-info (test-jump->info 0))
1468 (test-length (length (text->list (.text test+jump-info))))
1470 (skip-body-text (list (lambda (f g ta t d)
1471 (i386:Xjump (+ body-length step-length)))))
1473 (jump-text (list (lambda (f g ta t d)
1474 (i386:Xjump (- (+ body-length step-length test-length))))))
1475 (jump-length (length (text->list jump-text)))
1477 (test-text (.text (test-jump->info jump-length))))
1487 #:globals (append globals (list-tail (.globals body-info) (length globals)))
1490 ;; FIXME: support break statement (see switch/case)
1491 ((while ,test ,body)
1492 (let* ((skip-info (lambda (body-length)
1493 (clone info #:text (append text
1494 (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
1495 (text (.text (skip-info 0)))
1496 (text-length (length text))
1498 (body-info (lambda (body-length)
1499 ((ast->info (skip-info body-length)) body)))
1500 (body-text (list-tail (.text (body-info 0)) text-length))
1501 (body-length (length (text->list body-text)))
1503 (body-info (body-info body-length))
1505 (empty (clone info #:text '()))
1506 (test-jump->info ((test->jump->info empty) test))
1507 (test+jump-info (test-jump->info 0))
1508 (test-length (length (text->list (.text test+jump-info))))
1510 (jump-text (list (lambda (f g ta t d)
1511 (i386:Xjump (- (+ body-length test-length))))))
1512 (jump-length (length (text->list jump-text)))
1514 (test-text (.text (test-jump->info jump-length))))
1520 #:globals (.globals body-info))))
1522 ((do-while ,body ,test)
1523 (let* ((text-length (length text))
1525 (body-info ((ast->info info) body))
1526 (body-text (list-tail (.text body-info) text-length))
1527 (body-length (length (text->list body-text)))
1529 (empty (clone info #:text '()))
1530 (test-jump->info ((test->jump->info empty) test))
1531 (test+jump-info (test-jump->info 0))
1532 (test-length (length (text->list (.text test+jump-info))))
1534 (jump-text (list (lambda (f g ta t d)
1535 (i386:Xjump (- (+ body-length test-length))))))
1536 (jump-length (length (text->list jump-text)))
1538 (test-text (.text (test-jump->info jump-length))))
1544 #:globals (.globals body-info))))
1546 ((labeled-stmt (ident ,label) ,statement)
1547 (let ((info (clone info #:text (append text (list label)))))
1548 ((ast->info info) statement)))
1550 ((goto (ident ,label))
1551 (let* ((jump (lambda (n) (i386:XXjump n)))
1552 (offset (+ (length (jump 0)) (length (text->list text)))))
1555 (list (lambda (f g ta t d)
1556 (jump (- (label-offset (.function info) label f) offset))))))))
1558 ;;; FIXME: only zero?!
1559 ((p-expr (ident ,name))
1562 ((ident->accu info) name)
1563 (list (lambda (f g ta t d)
1565 (i386:accu-zero?)))))))
1567 ((p-expr (fixed ,value))
1568 (let ((value (cstring->number value)))
1571 (list (lambda (f g ta t d)
1573 (i386:value->accu value)
1574 (i386:accu-zero?))))))))
1576 ((de-ref (p-expr (ident ,name)))
1579 ((ident->accu info) name)
1580 (list (lambda (f g ta t d)
1582 (i386:byte-mem->accu)))))))
1584 ((fctn-call . ,call)
1585 (let ((info ((ast->info info) `(expr-stmt ,o))))
1587 (append (.text info)
1588 (list (lambda (f g ta t d)
1589 (i386:accu-zero?)))))))
1592 ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1593 ((post-inc (p-expr (ident ,name)))
1596 ((ident->accu info) name)
1597 ((ident-add info) name 1)
1598 (list (lambda (f g ta t d)
1600 (i386:accu-zero?)))))))
1601 ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1602 ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1603 ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1604 ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1607 ((expr-stmt (post-inc (p-expr (ident ,name))))
1608 (clone info #:text (append text ((ident-add info) name 1))))
1611 ((expr-stmt (pre-inc (p-expr (ident ,name))))
1612 (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
1615 ((ident-add info) name 1)
1616 ((ident->accu info) name)
1617 (list (lambda (f g ta t d)
1619 ;;(i386:local->accu (local:id (assoc-ref locals name)))
1620 (i386:accu-zero?)))))))
1623 ((expr-stmt (post-dec (p-expr (ident ,name))))
1624 (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
1627 ((ident->accu info) name)
1628 ((ident-add info) name -1)
1629 (list (lambda (f g ta t d)
1631 ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1632 (i386:accu-zero?)))))))
1635 ((expr-stmt (pre-dec (p-expr (ident ,name))))
1636 (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
1639 ((ident-add info) name -1)
1640 ((ident->accu info) name)
1641 (list (lambda (f g ta t d)
1643 ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1644 ;;(i386:local->accu (local:id (assoc-ref locals name)))
1645 (i386:accu-zero?)))))))
1648 (let* ((test-info ((ast->info info) expr)))
1650 (append (.text test-info)
1651 (list (lambda (f g ta t d)
1654 (i386:accu-zero?)))))
1655 #:globals (.globals test-info))))
1658 (let* ((base ((expr->base info) a))
1659 (empty (clone base #:text '()))
1660 (accu ((expr->accu empty) b)))
1664 (list (lambda (f g ta t d)
1667 (list (lambda (f g ta t d)
1669 (list (lambda (f g ta t d)
1670 (i386:sub-base)))))))
1673 (let* ((base ((expr->base info) a))
1674 (empty (clone base #:text '()))
1675 (accu ((expr->accu empty) b)))
1679 (list (lambda (f g ta t d)
1682 (list (lambda (f g ta t d)
1684 (list (lambda (f g ta t d)
1685 (i386:sub-base)))))))
1688 (let* ((base ((expr->base info) a))
1689 (empty (clone base #:text '()))
1690 (accu ((expr->accu empty) b)))
1694 (list (lambda (f g ta t d)
1697 (list (lambda (f g ta t d)
1699 (list (lambda (f g ta t d)
1700 (i386:sub-base)))))))
1703 (let* ((base ((expr->base info) a))
1704 (empty (clone base #:text '()))
1705 (accu ((expr->accu empty) b)))
1709 (list (lambda (f g ta t d)
1712 (list (lambda (f g ta t d)
1714 (list (lambda (f g ta t d)
1717 (i386:xor-zf))))))))
1720 (let* ((base ((expr->base info) a))
1721 (empty (clone base #:text '()))
1722 (accu ((expr->accu empty) b)))
1726 (list (lambda (f g ta t d)
1729 (list (lambda (f g ta t d)
1731 (list (lambda (f g ta t d)
1732 (i386:base-sub)))))))
1735 (let* ((base ((expr->base info) a))
1736 (empty (clone base #:text '()))
1737 (accu ((expr->accu empty) b)))
1741 (list (lambda (f g ta t d)
1744 (list (lambda (f g ta t d)
1746 (list (lambda (f g ta t d)
1747 (i386:base-sub)))))))
1750 ((lshift . _) ((expr->accu info) o))
1751 ((rshift . _) ((expr->accu info) o))
1753 ;; TODO: byte dinges
1755 (let* ((base ((expr->base info) a))
1756 (empty (clone base #:text '()))
1757 (accu ((expr->accu empty) b)))
1761 (list (lambda (f g ta t d)
1764 (list (lambda (f g ta t d)
1766 (list (lambda (f g ta t d)
1767 (i386:base-sub)))))))
1769 ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1772 (list (lambda (f g ta t d)
1774 (i386:local->accu (local:id (assoc-ref locals a)))
1775 (i386:byte-mem->base)
1776 (i386:local->accu (local:id (assoc-ref locals b)))
1777 (i386:byte-mem->accu)
1778 (i386:byte-sub-base)))))))
1781 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
1782 (let* ((value (cstring->number value))
1783 (type (ident->type info array))
1784 (size (type->size info type)))
1787 ((ident->base info) array)
1788 (list (lambda (f g ta t d)
1790 (i386:value->accu (* size index))
1792 (i386:byte-base-mem->accu)
1793 (i386:base-mem->accu)))))))))
1796 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1797 (let* ((type (ident->type info array))
1798 (size (type->size info type)))
1801 ((ident->base info) index)
1802 (list (lambda (f g ta t d)
1808 (if (= size 12) (i386:accu+base) '())
1809 (i386:accu-shl 2))))))
1810 ((ident->base info) array)
1811 (list (lambda (f g ta t d)
1813 (i386:byte-base-mem->accu)
1814 (i386:base-mem->accu))))))))
1817 (let ((accu ((expr->accu info) expr)))
1819 (append (.text accu) (list (lambda (f g ta t d) (i386:ret)))))))
1822 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1823 (if (.function info)
1824 (clone info #:locals (add-local locals name type 0))
1825 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1828 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1829 (let ((value (cstring->number value)))
1830 (if (.function info)
1831 (let* ((locals (add-local locals name type 0))
1832 (info (clone info #:locals locals)))
1835 ((value->ident info) name value))))
1836 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1839 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1840 (if (not (.function info)) decl-barf0)
1841 (let* ((locals (add-local locals name type 0))
1842 (info (clone info #:locals locals))
1843 (value (char->integer (car (string->list value)))))
1846 ((value->ident info) name value)))))
1849 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1850 (let ((value (- (cstring->number value))))
1851 (if (.function info)
1852 (let* ((locals (add-local locals name type 0))
1853 (info (clone info #:locals locals)))
1856 ((value->ident info) name value))))
1857 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1860 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1861 (if (not (.function info)) decl-barf2)
1862 (let* ((locals (add-local locals name type 0))
1863 (info (clone info #:locals locals)))
1866 ((ident->accu info) local)
1867 ((accu->ident info) name)))))
1870 ;;(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"))))))
1871 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1872 (when (not (.function info))
1875 (let* ((locals (add-local locals name type 1))
1876 (globals (append globals (list (string->global string))))
1877 (info (clone info #:locals locals #:globals globals)))
1880 (list (lambda (f g ta t d)
1882 (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1883 ((accu->ident info) name)))))
1886 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
1887 (let ((value (cstring->number value)))
1888 (if (.function info)
1889 (let* ((locals (add-local locals name type 1))
1890 (info (clone info #:locals locals)))
1893 (list (lambda (f g ta t d)
1894 (i386:value->accu value)))
1895 ((accu->ident info) name))))
1896 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1898 ;; char arena[20000];
1899 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1900 (let ((type (ast->type type)))
1901 (if (.function info)
1903 (let* ((globals (.globals info))
1904 (count (cstring->number count))
1905 (size (type->size info type))
1906 ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1907 (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1908 (globals (append globals (list array))))
1910 #:globals globals)))))
1912 ;;struct scm *g_cells = (struct scm*)arena;
1913 ((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)))))))
1914 ;;(stderr "0TYPE: ~s\n" type)
1915 (if (.function info)
1916 (let* ((locals (add-local locals name type 1))
1917 (info (clone info #:locals locals)))
1920 ((ident->accu info) name)
1921 ((accu->ident info) value)))) ;; FIXME: deref?
1922 (let* ((globals (append globals (list (ident->global name type 1 0))))
1923 (info (clone info #:globals globals)))
1926 ((ident->accu info) name)
1927 ((accu->ident info) value)))))) ;; FIXME: deref?
1930 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1931 ;;(stderr "1TYPE: ~s\n" type)
1932 (if (.function info)
1933 (clone info #:locals (add-local locals name type 0))
1934 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1937 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1938 ;;(stderr "2TYPE: ~s\n" type)
1939 (let ((value (cstring->number value)))
1940 (if (.function info)
1941 (let* ((locals (add-local locals name type 0))
1942 (info (clone info #:locals locals)))
1945 ((value->ident info) name value))))
1946 (let ((globals (append globals (list (ident->global name type 0 value)))))
1947 (clone info #:globals globals)))))
1949 ;; SCM g_stack = 0; // comment
1950 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1951 ((ast->info info) (list-head o (- (length o) 1))))
1954 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1955 ;;(stderr "3TYPE: ~s\n" type)
1956 (if (.function info)
1957 (let* ((locals (add-local locals name type 0))
1958 (info (clone info #:locals locals)))
1961 ((ident->accu info) local)
1962 ((accu->ident info) name))))
1963 (let* ((globals (append globals (list (ident->global name type 0 0))))
1964 (info (clone info #:globals globals)))
1967 ((ident->accu info) local)
1968 ((accu->ident info) name))))))
1970 ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1971 ((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))))
1972 (let* ((locals (add-local locals name type 1))
1973 (info (clone info #:locals locals))
1974 (empty (clone info #:text '()))
1975 (accu ((expr->accu empty) initzer)))
1980 ((accu->ident info) name)
1981 (list (lambda (f g ta t d)
1983 ;;(i386:value->base t)
1985 (i386:value->base ta)
1986 (i386:accu+base)))))
1989 ;; char *p = (char*)g_cells;
1990 ((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)))))))
1991 ;;(stderr "6TYPE: ~s\n" type)
1992 (if (.function info)
1993 (let* ((locals (add-local locals name type 1))
1994 (info (clone info #:locals locals)))
1997 ((ident->accu info) value)
1998 ((accu->ident info) name))))
1999 (let* ((globals (append globals (list (ident->global name type 1 0))))
2000 (here (data-offset name globals))
2001 (there (data-offset value globals)))
2004 #:init (append (.init info)
2005 (list (lambda (functions globals ta t d data)
2007 (list-head data here)
2009 ;;; char *x = arena;
2010 (int->bv32 (+ d (data-offset value globals)))
2012 ;;;(list-head (list-tail data there) 4)
2013 (list-tail data (+ here 4))))))))))
2015 ;; char *p = g_cells;
2016 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
2017 ;;(stderr "7TYPE: ~s\n" type)
2018 (let ((type (decl->type type)))
2019 ;;(stderr "0DECL: ~s\n" type)
2020 (if (.function info)
2021 (let* ((locals (add-local locals name type 1))
2022 (info (clone info #:locals locals)))
2025 ((ident->accu info) value)
2026 ((accu->ident info) name))))
2027 (let* ((globals (append globals (list (ident->global name type 1 0))))
2028 (here (data-offset name globals)))
2031 #:init (append (.init info)
2032 (list (lambda (functions globals ta t d data)
2034 (list-head data here)
2036 ;;; char *x = arena;p
2037 (int->bv32 (+ d (data-offset value globals)))
2038 (list-tail data (+ here 4)))))))))))
2041 ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
2042 (let ((type (enum->type name fields))
2043 (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
2045 #:types (append (.types info) (list type))
2046 #:constants (append constants (.constants info)))))
2049 ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
2050 (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
2051 ;;(stderr "type: ~a\n" type)
2052 (clone info #:types (append (.types info) (list type)))))
2055 ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
2056 (when (not (equal? op "="))
2057 (stderr "OOOPS0.0: op=~s\n" op)
2059 (let* ((empty (clone info #:text '()))
2060 (base ((expr->base empty) b)))
2064 ((base->ident-address info) name)
2065 ((ident-add info) name 1)))))
2068 ((expr-stmt (assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b))
2069 (when (not (equal? op "="))
2070 (stderr "OOOPS0.0: op=~s\n" op)
2072 (let* ((empty (clone info #:text '()))
2073 (base ((expr->base empty) b)))
2077 ((base->ident-address info) name)
2078 ((ident-add info) name -1)))))
2082 ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
2083 (when (not (equal? op "="))
2084 (stderr "OOOPS0: op=~s\n" op)
2086 (let* ((empty (clone info #:text '()))
2087 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
2088 (base ((expr->base empty) b))
2089 (type (list "struct" "scm")) ;; FIXME
2090 (fields (type->description info type))
2091 (size (type->size info type))
2092 (field-size 4) ;; FIXME:4, not fixed
2093 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) )
2094 (clone info #:text (append text
2097 (list (lambda (f g ta t d)
2098 ;;(i386:byte-base->accu-ref) ;; FIXME: size
2099 (i386:base->accu-address)
2107 ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
2108 (when (and (not (equal? op "="))
2109 (not (equal? op "+="))
2110 (not (equal? op "-=")))
2111 (stderr "OOOPS1: op=~s\n" op)
2113 (let* ((empty (clone info #:text '()))
2114 (base ((expr->base empty) b)))
2115 (clone info #:text (append text
2117 (if (equal? op "=") '()
2118 (append ((ident->accu info) name)
2119 (list (lambda (f g ta t d)
2121 (if (equal? op "+=")
2124 (i386:accu->base))))))
2126 ((base->ident info) name)))))
2129 ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
2130 (when (not (equal? op "="))
2131 (stderr "OOOPS2: op=~s\n" op)
2133 (let* ((empty (clone info #:text '()))
2134 (base ((expr->base empty) b)))
2135 (clone info #:text (append text
2138 ((base->ident-address info) array)))))
2141 ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2142 (when (not (equal? op "="))
2143 (stderr "OOOPS3: op=~s\n" op)
2145 (let* ((index (cstring->number index))
2146 (empty (clone info #:text '()))
2147 (base ((expr->base empty) b))
2148 (type (ident->type info array))
2149 (size (type->size info type))
2150 (ptr (ident->pointer info array)))
2154 (list (lambda (f g ta t d)
2156 (list (lambda (f g ta t d)
2158 (i386:value->base index)
2160 (if (eq? size 1) '()
2162 (if (> size 4) (i386:accu+accu) '())
2163 (if (> size 8) (i386:accu+base) '())
2164 (i386:accu-shl 2))))))
2165 ((ident->base info) array)
2166 (list (lambda (f g ta t d)
2168 (list (lambda (f g ta t d)
2170 (if (eq? size 1) (list (lambda (f g ta t d)
2171 (i386:byte-base->accu-address)))
2173 (list (lambda (f g ta t d)
2174 (i386:base-address->accu-address)))
2176 (list (lambda (f g ta t d)
2180 (i386:base-address->accu-address))))
2183 (list (lambda (f g ta t d)
2187 (i386:base-address->accu-address))))
2191 ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
2192 ;;(stderr "pointer_cells4[]: ~s\n" array)
2193 (when (not (equal? op "="))
2194 (stderr "OOOPS4: op=~s\n" op)
2196 (let* ((empty (clone info #:text '()))
2197 (base ((expr->base empty) b))
2198 (type (ident->type info array))
2199 (size (type->size info type))
2200 (ptr (ident->pointer info array)))
2204 (list (lambda (f g ta t d)
2206 ((ident->base info) index)
2207 (list (lambda (f g ta t d)
2210 (if (eq? size 1) '()
2212 (if (> size 4) (i386:accu+accu) '())
2213 (if (> size 8) (i386:accu+base) '())
2214 (i386:accu-shl 2))))))
2215 ((ident->base info) array)
2216 (list (lambda (f g ta t d)
2218 (list (lambda (f g ta t d)
2220 (if (eq? size 1) (list (lambda (f g ta t d)
2221 (i386:byte-base->accu-address)))
2223 (list (lambda (f g ta t d)
2224 (i386:base-address->accu-address)))
2226 (list (lambda (f g ta t d)
2230 (i386:base-address->accu-address))))
2233 (list (lambda (f g ta t d)
2237 (i386:base-address->accu-address))))
2240 ;; g_functions[g_function++] = g_foo;
2241 ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
2242 (when (not (equal? op "="))
2243 (stderr "OOOPS5: op=~s\n" op)
2245 (let* ((empty (clone info #:text '()))
2246 (base ((expr->base empty) b))
2247 (type (ident->type info array))
2248 (size (type->size info type))
2249 (ptr (ident->pointer info array)))
2253 (list (lambda (f g ta t d)
2255 ((ident->base info) index)
2256 (list (lambda (f g ta t d)
2259 (if (eq? size 1) '()
2261 (if (> size 4) (i386:accu+accu) '())
2262 (if (> size 8) (i386:accu+base) '())
2263 (i386:accu-shl 2))))))
2264 ((ident->base info) array)
2265 (list (lambda (f g ta t d)
2267 (list (lambda (f g ta t d)
2269 (if (eq? size 1) (list (lambda (f g ta t d)
2270 (i386:byte-base->accu-address)))
2272 (list (lambda (f g ta t d)
2273 (i386:base-address->accu-address)))
2275 (list (lambda (f g ta t d)
2279 (i386:base-address->accu-address))))
2282 (list (lambda (f g ta t d)
2286 (i386:base-address->accu-address))))
2288 ((ident-add info) index 1)))))
2292 ;; struct f = {...};
2293 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
2294 (let* ((type (decl->type type))
2295 ;;(foo (stderr "1DECL: ~s\n" type))
2296 (fields (type->description info type))
2297 (size (type->size info type))
2298 (field-size 4)) ;; FIXME:4, not fixed
2299 ;;(stderr "7TYPE: ~s\n" type)
2300 (if (.function info)
2301 (let* ((globals (append globals (filter-map initzer->global initzers)))
2302 (locals (let loop ((fields (cdr fields)) (locals locals))
2303 (if (null? fields) locals
2304 (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
2305 (locals (add-local locals name type -1))
2306 (info (clone info #:locals locals #:globals globals))
2307 (empty (clone info #:text '())))
2308 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2309 (if (null? fields) info
2310 (let ((offset (* field-size (car fields)))
2311 (initzer (car initzers)))
2312 (loop (cdr fields) (cdr initzers)
2316 ((ident->accu info) name)
2317 (list (lambda (f g ta t d)
2319 (i386:accu->base))))
2320 (.text ((expr->accu empty) initzer))
2321 (list (lambda (f g ta t d)
2322 (i386:accu->base-address+n offset))))))))))
2323 (let* ((globals (append globals (filter-map initzer->global initzers)))
2324 (global (make-global name type -1 (string->list (make-string size #\nul))))
2325 (globals (append globals (list global)))
2326 (here (data-offset name globals))
2327 (info (clone info #:globals globals))
2329 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2330 (if (null? fields) info
2331 (let ((offset (* field-size (car fields)))
2332 (initzer (car initzers)))
2333 (loop (cdr fields) (cdr initzers)
2337 (list (lambda (functions globals ta t d data)
2339 (list-head data (+ here offset))
2340 (initzer->data info functions globals ta t d (car initzers))
2341 (list-tail data (+ here offset field-size)))))))))))))))
2344 ;;char cc = g_cells[c].cdr; ==> generic?
2345 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
2346 (let ((type (decl->type type)))
2347 (if (.function info)
2348 (let* ((locals (add-local locals name type 0))
2349 (info (clone info #:locals locals)))
2351 (append (.text ((expr->accu info) initzer))
2352 ((accu->ident info) name))))
2353 (let* ((globals (append globals (list (ident->global name type 1 0))))
2354 (here (data-offset name globals)))
2357 #:init (append (.init info)
2358 (list (lambda (functions globals ta t d data)
2360 (list-head data here)
2361 (initzer->data info functions globals ta t d initzer)
2362 (list-tail data (+ here 4)))))))))))
2365 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
2368 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
2371 ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
2372 (let ((types (.types info)))
2373 (clone info #:types (cons (cons name (assoc-ref types type)) types))))
2375 ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
2376 (format (current-error-port) "SKIP: typedef=~s\n" o)
2380 (format (current-error-port) "SKIP: at=~s\n" o)
2384 (format (current-error-port) "SKIP: decl statement=~s\n" o)
2389 (format (current-error-port) "SKIP: statement=~s\n" o)
2393 (define (initzer->data info functions globals ta t d o)
2395 ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2396 ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
2397 ((initzer (ref-to (p-expr (ident ,name))))
2398 ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2399 (int->bv32 (+ ta (function-offset name functions))))
2400 ((initzer (p-expr (ident ,name)))
2401 (let ((value (assoc-ref (.constants info) name)))
2403 ((initzer (p-expr (string ,string)))
2404 (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2405 (_ (stderr "initzer->data:SKIP: ~s\n" o)
2409 (define (info->exe info)
2410 (display "dumping elf\n" (current-error-port))
2411 (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2413 (define (.formals o)
2415 ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2416 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2417 (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2420 (define (formal->text n)
2426 (define (formals->text o)
2428 ((param-list . ,formals)
2429 (let ((n (length formals)))
2430 (list (lambda (f g ta t d)
2432 (i386:function-preamble)
2433 (append-map (formal->text n) formals (iota n))
2434 (i386:function-locals))))))
2435 (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2438 (define (formal:ptr o)
2440 ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
2442 ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
2445 (stderr "formal:ptr[~a] => 0\n" o)
2448 (define (formals->locals o)
2450 ((param-list . ,formals)
2451 (let ((n (length formals)))
2452 (map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
2453 (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2456 (define (function->info info)
2458 ;;(stderr "function->info o=~s\n" o)
2459 ;;(stderr "formals=~s\n" (.formals o))
2460 (let* ((name (.name o))
2461 (formals (.formals o))
2462 (text (formals->text formals))
2463 (locals (formals->locals formals)))
2464 (format (current-error-port) "compiling ~s\n" name)
2465 ;;(stderr "locals=~s\n" locals)
2466 (let loop ((statements (.statements o))
2467 (info (clone info #:locals locals #:function (.name o) #:text text)))
2468 (if (null? statements) (clone info
2470 #:functions (append (.functions info) (list (cons name (.text info)))))
2471 (let* ((statement (car statements)))
2472 (loop (cdr statements)
2473 ((ast->info info) (car statements)))))))))
2475 (define (ast-list->info info)
2477 (let loop ((elements elements) (info info))
2478 (if (null? elements) info
2479 (loop (cdr elements) ((ast->info info) (car elements)))))))
2482 (stderr "COMPILE\n")
2483 (let* ((ast (mescc))
2485 #:functions i386:libc
2486 #:types i386:type-alist))
2487 (ast (append libc ast))
2488 (info ((ast->info info) ast))
2489 (info ((ast->info info) _start)))