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
32 (set-port-encoding! (current-output-port) "ISO-8859-1"))
35 (mes-use-module (nyacc lang c99 parser))
36 (mes-use-module (mes elf-util))
37 (mes-use-module (mes pmatch))
38 (mes-use-module (mes elf))
39 (mes-use-module (mes libc-i386))
40 (mes-use-module (mes optargs))))
42 (define (logf port string . rest)
43 (apply format (cons* port string rest))
47 (define (stderr string . rest)
48 (apply logf (cons* (current-error-port) string rest)))
50 (define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
54 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
66 (write-char (cond ((char? x) x)
67 ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
68 ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
70 (stderr "write-any: proc: ~a\n" x)
71 (stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
73 (else (stderr "write-any: ~a\n" x) barf))))
75 (define (ast:function? o)
76 (and (pair? o) (eq? (car o) 'fctn-defn)))
80 ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
81 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
82 ((param-decl _ (param-declr (ident ,name))) name)
83 ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
84 ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
86 (format (current-error-port) "SKIP: .name =~a\n" o))))
90 ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
91 ((param-decl ,type _) type)
93 (format (current-error-port) "SKIP: .type =~a\n" o))))
95 (define (.statements o)
97 ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
98 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
100 (define <info> '<info>)
101 (define <types> '<types>)
102 (define <constants> '<constants>)
103 (define <functions> '<functions>)
104 (define <globals> '<globals>)
105 (define <init> '<init>)
106 (define <locals> '<locals>)
107 (define <function> '<function>)
108 (define <text> '<text>)
110 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()))
114 (cons <constants> constants)
115 (cons <functions> functions)
116 (cons <globals> globals)
118 (cons <locals> locals)
119 (cons <function> function)
120 (cons <text> text)))))
124 ((<info> . ,alist) (assq-ref alist <types>))))
126 (define (.constants o)
128 ((<info> . ,alist) (assq-ref alist <constants>))))
130 (define (.functions o)
132 ((<info> . ,alist) (assq-ref alist <functions>))))
136 ((<info> . ,alist) (assq-ref alist <globals>))))
140 ((<info> . ,alist) (assq-ref alist <init>))))
144 ((<info> . ,alist) (assq-ref alist <locals>))))
146 (define (.function o)
148 ((<info> . ,alist) (assq-ref alist <function>))))
152 ((<info> . ,alist) (assq-ref alist <text>))))
155 (and (pair? o) (eq? (car o) <info>)))
157 (define (clone o . rest)
159 (let ((types (.types o))
160 (constants (.constants o))
161 (functions (.functions o))
162 (globals (.globals o))
165 (function (.function o))
170 (constants constants)
171 (functions functions)
177 (make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text))))))
179 (define (push-global globals)
182 (i386:push-global (+ (data-offset o g) d)))))
184 (define (push-local locals)
187 (i386:push-local (local:id o)))))
189 (define (push-global-address globals)
192 (i386:push-global-address (+ (data-offset o g) d)))))
194 (define (push-local-address locals)
197 (i386:push-local-address (local:id o)))))
199 (define push-global-de-ref push-global)
201 (define (push-local-de-ref locals)
204 (i386:push-local-de-ref (local:id o)))))
206 (define (string->global string)
207 (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
209 (define (ident->global name type pointer value)
210 (make-global name type pointer (int->bv32 value)))
212 (define (make-local name type pointer id)
213 (cons name (list type pointer id)))
214 (define local:type car)
215 (define local:pointer cadr)
216 (define local:id caddr)
218 (define (push-ident info)
220 (let ((local (assoc-ref (.locals info) o)))
221 (if local ((push-local (.locals info)) local)
222 ((push-global (.globals info)) o))))) ;; FIXME: char*/int
224 (define (push-ident-address info)
226 (let ((local (assoc-ref (.locals info) o)))
227 (if local ((push-local-address (.locals info)) local)
228 ((push-global-address (.globals info)) o)))))
230 (define (push-ident-de-ref info)
232 (let ((local (assoc-ref (.locals info) o)))
233 (if local ((push-local-de-ref (.locals info)) local)
234 ((push-global-de-ref (.globals info)) o)))))
236 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
238 (let ((text (.text info)))
240 ((p-expr (fixed ,value))
241 (let ((value (cstring->number value)))
242 (clone info #:text (append text
246 (i386:value->accu value)
247 (i386:push-accu))))))))
249 ((neg (p-expr (fixed ,value)))
250 (let ((value (- (cstring->number value))))
251 (clone info #:text (append text
255 (i386:value->accu value)
256 (i386:push-accu))))))))
258 ((p-expr (string ,string))
259 (clone info #:text (append text (list ((push-global-address info) (add-s:-prefix string))))))
261 ((p-expr (ident ,name))
262 (clone info #:text (append text (list ((push-ident info) name)))))
265 ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
266 (let ((index (cstring->number index))
267 (size 4)) ;; FIXME: type: int
270 ((ident->base info) array)
274 (i386:value->accu (* size index)) ;; FIXME: type: int
275 (i386:base-mem->accu) ;; FIXME: type: int
276 (i386:push-accu))))))))
279 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
280 (let ((index (cstring->number index))
281 (size 4)) ;; FIXME: type: int
282 (clone info #:text (append text
283 ((ident->base info) array)
284 ((ident->accu info) array)
287 (i386:base-mem->accu)))
290 (i386:push-accu)))))))
292 ((de-ref (p-expr (ident ,name)))
293 (clone info #:text (append text (list ((push-ident-de-ref info) name)))))
295 ((ref-to (p-expr (ident ,name)))
296 (clone info #:text (append text (list ((push-ident-address info) name)))))
300 (let* (;;(empty (clone info #:text '()))
301 ;;(info ((ast->info empty) o))
302 (info ((ast->info info) o))
308 (i386:push-accu)))))))
312 (let* (;;(empty (clone info #:text '()))
313 ;;(expr ((expr->accu empty) `(d-sel ,@d-sel)))
314 (expr ((expr->accu info) `(d-sel ,@d-sel)))
318 (list (lambda (f g ta t d)
319 (i386:push-accu)))))))
322 ((p-expr (char ,char))
323 (let ((char (char->integer (car (string->list char)))))
326 (list (lambda (f g ta t d)
328 (i386:value->accu char)
329 (i386:push-accu)))))))
333 ;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
335 ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
336 (abs-declr (pointer)))
338 ((expr->arg info) cast))
340 (format (current-error-port) "SKIP: expr->arg=~s\n" o)
344 ;; FIXME: see ident->base
345 (define (ident->accu info)
347 (let ((local (assoc-ref (.locals info) o))
348 (global (assoc-ref (.globals info) o))
349 (constant (assoc-ref (.constants info) o)))
350 ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
351 ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
352 ;; (stderr "globals: ~a\n" (.globals info))
353 ;; (if (and (not global) (not (local:id local)))
354 ;; (stderr "globals: ~a\n" (map car (.globals info))))
356 (let ((ptr (local:pointer local)))
357 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
358 (cond ((equal? o "c1")
359 (list (lambda (f g ta t d)
360 (i386:byte-local->accu (local:id local))))) ;; FIXME type
361 ((equal? o "functionx")
362 (list (lambda (f g ta t d)
363 (i386:local->accu (local:id local))))) ;; FIXME type
366 ((-1) (list (lambda (f g ta t d)
367 (i386:local-ptr->accu (local:id local)))))
368 (else (list (lambda (f g ta t d)
369 (i386:local->accu (local:id local)))))))))
371 (let ((ptr (ident->pointer info o)))
372 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
374 ((-1) (list (lambda (f g ta t d)
375 (i386:global->accu (+ (data-offset o g) d)))))
376 (else (list (lambda (f g ta t d)
377 (i386:global-address->accu (+ (data-offset o g) d)))))))
379 (list (lambda (f g ta t d)
380 (i386:value->accu constant)))
381 (list (lambda (f g ta t d)
382 (i386:global->accu (+ ta (function-offset o f)))))))))))
384 (define (value->accu v)
385 (list (lambda (f g ta t d)
386 (i386:value->accu v))))
388 (define (accu->ident info)
390 (let ((local (assoc-ref (.locals info) o)))
392 (list (lambda (f g ta t d)
393 (i386:accu->local (local:id local))))
394 (list (lambda (f g ta t d)
395 (i386:accu->global (+ (data-offset o g) d))))))))
397 (define (base->ident info)
399 (let ((local (assoc-ref (.locals info) o)))
401 (list (lambda (f g ta t d)
402 (i386:base->local (local:id local))))
403 (list (lambda (f g ta t d)
404 (i386:base->global (+ (data-offset o g) d))))))))
406 (define (base->ident-address info)
408 (let ((local (assoc-ref (.locals info) o)))
410 (list (lambda (f g ta t d)
412 (i386:local->accu (local:id local))
413 (i386:byte-base->accu-address))))
414 TODO:base->ident-address-global))))
416 (define (value->ident info)
418 (let ((local (assoc-ref (.locals info) o)))
420 (list (lambda (f g ta t d)
421 (i386:value->local (local:id local) value)))
422 (list (lambda (f g ta t d)
423 (i386:value->global (+ (data-offset o g) d) value)))))))
425 (define (ident-add info)
427 (let ((local (assoc-ref (.locals info) o)))
429 (list (lambda (f g ta t d)
430 (i386:local-add (local:id local) n)))
431 (list (lambda (f g ta t d)
432 (i386:global-add (+ (data-offset o g) d) n)))))))
434 ;; FIXME: see ident->accu
435 (define (ident->base info)
437 (let ((local (assoc-ref (.locals info) o)))
438 ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
440 (list (lambda (f g ta t d)
441 (i386:local->base (local:id local))))
442 (let ((global (assoc-ref (.globals info) o) ))
444 (let ((ptr (ident->pointer info o)))
445 ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
447 ((-1) (list (lambda (f g ta t d)
448 (i386:global->base (+ (data-offset o g) d)))))
449 (else (list (lambda (f g ta t d)
450 (i386:global-address->base (+ (data-offset o g) d)))))))
451 (let ((constant (assoc-ref (.constants info) o)))
453 (list (lambda (f g ta t d)
454 (i386:value->base constant)))
455 (list (lambda (f g ta t d)
456 (i386:global->base (+ ta (function-offset o f)))))))))))))
458 (define (expr->accu info)
460 (let ((text (.text info))
461 (locals (.locals info))
462 (globals (.globals info)))
463 ;;(stderr "expr->accu o=~a\n" o)
465 ((p-expr (string ,string))
466 (clone info #:text (append text (list (lambda (f g ta t d)
467 ;;(stderr "OFF[~a]: ~a\n" string (data-offset string globals))
468 ;;(stderr "globals: ~s\n" (map car globals))
469 (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
470 ((p-expr (fixed ,value))
471 (clone info #:text (append text (value->accu (cstring->number value)))))
472 ((p-expr (ident ,name))
473 (clone info #:text (append text ((ident->accu info) name))))
474 ((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
475 ((not (fctn-call . _)) ((ast->info info) o))
476 ((neg (p-expr (fixed ,value)))
477 (clone info #:text (append text (value->accu (- (cstring->number value))))))
479 ((initzer ,initzer) ((expr->accu info) initzer))
480 ((ref-to (p-expr (ident ,name)))
483 ((ident->accu info) name))))
485 ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
486 (let* (;;(type (assoc-ref (.types info) (list "struct" name)))
487 (type (list "struct" name))
488 (fields (or (type->description info type) '()))
489 (size (type->size info type)))
490 (stderr "SIZEOF: type=~s => ~s\n" type size)
493 (list (lambda (f g ta t d)
495 (i386:value->accu size))))))))
497 ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,array)))
498 (let ((value (cstring->number value)))
501 ((ident->base info) array)
502 (list (lambda (f g ta t d)
504 (i386:value->accu value)
505 ;;(i386:byte-base-mem->accu) ;; FIXME: int/char
506 (i386:base-mem->accu)
510 ((d-sel (ident ,field) (p-expr (ident ,array)))
511 (let* ((type (ident->type info array))
512 (fields (type->description info type))
513 (field-size 4) ;; FIXME:4, not fixed
514 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
518 ((ident->accu info) array)
519 (list (lambda (f g ta t d)
520 (i386:mem+n->accu offset)))))))
523 ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
524 (let* ((type (ident->type info array))
525 (fields (or (type->description info type) '()))
526 (size (type->size info type))
527 (count (length fields))
528 (field-size 4) ;; FIXME:4, not fixed
529 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
530 (index (cstring->number index))
534 (list (lambda (f g ta t d)
536 (i386:value->base index)
538 (if (> count 1) (i386:accu+accu) '())
539 (if (= count 3) (i386:accu+base) '())
541 ((ident->base info) array)
542 (list (lambda (f g ta t d)
543 (i386:base-mem+n->accu offset)))))))
546 ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
547 (let* ((type (ident->type info array))
548 (fields (or (type->description info type) '()))
549 (size (type->size info type))
550 (count (length fields))
551 (field-size 4) ;; FIXME:4, not fixed
552 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
556 ((ident->base info) index)
557 (list (lambda (f g ta t d)
560 (if (> count 1) (i386:accu+accu) '())
561 (if (= count 3) (i386:accu+base) '())
563 ((ident->base info) array)
564 (list (lambda (f g ta t d)
565 (i386:base-mem+n->accu offset)))))))
567 ;; g_functions[g_cells[fn].cdr].arity
568 ;; INDEX0: g_cells[fn].cdr
570 ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
571 ;;((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)))))
572 ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
573 (let* ((empty (clone info #:text '()))
574 (index ((expr->accu empty) index))
575 (type (ident->type info array))
576 (fields (or (type->description info type) '()))
577 (size (type->size info type))
578 (count (length fields))
579 (field-size 4) ;; FIXME:4, not fixed
580 (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
583 (offset (* field-size (1- (length rest))))
588 (list (lambda (f g ta t d)
591 (if (> count 1) (i386:accu+accu) '())
592 (if (= count 3) (i386:accu+base) '())
594 ((ident->base info) array)
595 (list (lambda (f g ta t d)
596 (i386:base-mem+n->accu offset)))))))
598 ;;; FIXME: FROM INFO ...only zero?!
599 ((p-expr (fixed ,value))
600 (let ((value (cstring->number value)))
603 (list (lambda (f g ta t d)
604 (i386:value->accu value)))))))
606 ((p-expr (char ,char))
607 (let ((char (char->integer (car (string->list char)))))
610 (list (lambda (f g ta t d)
611 (i386:value->accu char)))))))
613 ((p-expr (ident ,name))
616 ((ident->accu info) name))))
618 ((de-ref (p-expr (ident ,name)))
621 ((ident->accu info) name)
622 (list (lambda (f g ta t d)
624 (cond ((equal? name "functionx") (i386:mem->accu))
625 (else (i386:byte-mem->accu))))))))) ;; FIXME: type
627 ;; GRR --> info again??!?
629 ((ast->info info) `(expr-stmt ,o)))
631 ((cond-expr . ,cond-expr)
632 ((ast->info info) `(expr-stmt ,o)))
635 ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
636 ((post-inc (p-expr (ident ,name)))
639 ((ident->accu info) name)
640 ((ident-add info) name 1))))
642 ;; GRR --> info again??!?
643 ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
644 ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
645 ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
646 ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
648 ((add (p-expr (ident ,name)) ,b)
649 (let* ((empty (clone info #:text '()))
650 (base ((expr->base empty) b)))
654 ((ident->accu info) name)
655 (list (lambda (f g ta t d)
656 (i386:accu+base)))))))
659 (let* ((empty (clone info #:text '()))
660 (accu ((expr->accu empty) a))
661 (base ((expr->base empty) b)))
666 (list (lambda (f g ta t d)
667 (i386:accu+base)))))))
670 (let* ((empty (clone info #:text '()))
671 (accu ((expr->accu empty) a))
672 (base ((expr->base empty) b)))
677 (list (lambda (f g ta t d)
678 (i386:accu-base)))))))
680 ((lshift ,a (p-expr (fixed ,value)))
681 (let* ((empty (clone info #:text '()))
682 (accu ((expr->accu empty) a))
683 (value (cstring->number value)))
687 (list (lambda (f g ta t d)
688 (i386:accu-shl value)))))))
691 (let* ((empty (clone info #:text '()))
692 (accu ((expr->accu empty) a))
693 (base ((expr->base empty) b)))
698 (list (lambda (f g ta t d)
699 (i386:accu/base)))))))
701 ;;((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"))))))
703 ((expr->accu info) o))
706 (format (current-error-port) "SKIP: expr->accu=~s\n" o)
710 (define (expr->base info)
712 (let ((info ((expr->accu info) o)))
715 (list (lambda (f g ta t d)
718 (list (lambda (f g ta t d)
721 (i386:pop-accu)))))))))
723 (define (expr->accu* info)
727 ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
728 (let* ((type (ident->type info array))
729 (fields (or (type->description info type) '()))
730 (size (type->size info type))
731 (count (length fields))
732 (field-size 4) ;; FIXME:4, not fixed
733 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
734 (index (cstring->number index))
738 (list (lambda (f g ta t d)
740 (i386:value->base index)
742 (if (> count 1) (i386:accu+accu) '())
743 (if (= count 3) (i386:accu+base) '())
745 ;; de-ref: g_cells, non: arena
746 ;;((ident->base info) array)
747 ((ident->base info) array)
748 (list (lambda (f g ta t d)
751 (i386:accu+value offset))))))))
754 ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
755 (let* ((type (ident->type info array))
756 (fields (or (type->description info type) '()))
757 (size (type->size info type))
758 (count (length fields))
759 (field-size 4) ;; FIXME:4, not fixed
760 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
764 ((ident->base info) index)
765 (list (lambda (f g ta t d)
768 (if (> count 1) (i386:accu+accu) '())
769 (if (= count 3) (i386:accu+base) '())
771 ;; de-ref: g_cells, non: arena
772 ;;((ident->base info) array)
773 ((ident->base info) array)
774 (list (lambda (f g ta t d)
777 (i386:accu+value offset))))))))
779 ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
780 ((d-sel (ident ,field) (p-expr (ident ,name)))
781 (let* ((type (ident->type info name))
782 (fields (or (type->description info type) '()))
783 (field-size 4) ;; FIXME
784 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
788 ((ident->accu info) name)
789 (list (lambda (f g ta t d)
790 (i386:accu+value offset)))))))
793 (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
798 (define (ident->constant name value)
801 (define (make-type name type size description)
802 (cons name (list type size description)))
804 (define (enum->type name fields)
805 (make-type name 'enum 4 fields))
807 (define (struct->type name fields)
808 (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
810 (define (decl->type o)
812 ((fixed-type ,type) type)
813 ((struct-ref (ident ,name)) (list "struct" name))
814 ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
815 (list "struct" name)) ;; FIXME
817 ;;(stderr "SKIP: decl type=~s\n" o)
820 (define (expr->global o)
822 ((p-expr (string ,string)) (string->global string))
825 (define (initzer->global o)
827 ((initzer ,initzer) (expr->global initzer))
830 (define (byte->hex o)
831 (string->number (string-drop o 2) 16))
834 (let ((prefix ".byte "))
835 (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
836 (let ((s (string-drop o (string-length prefix))))
837 (map byte->hex (string-split s #\space))))))
839 (define (case->jump-info info)
841 (list (lambda (f g ta t d) (i386:Xjump n))))
843 (list (lambda (f g ta t d) (i386:Xjump-nz n))))
844 (define (statement->info info body-length)
847 ((break) (clone info #:text (append (.text info) (jump body-length)
850 ((ast->info info) o)))))
853 ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
854 (lambda (body-length)
856 (define (test->text value clause-length)
857 (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
858 (jump-nz clause-length)))
859 (let* ((value (assoc-ref (.constants info) constant))
861 (clone info #:text (append (.text info) (test->text value 0))))
862 (text-length (length (.text test-info)))
863 (clause-info (let loop ((elements elements) (info test-info))
864 (if (null? elements) info
865 (loop (cdr elements) ((statement->info info body-length) (car elements))))))
866 (clause-text (list-tail (.text clause-info) text-length))
867 (clause-length (length (text->list clause-text))))
868 (clone info #:text (append
870 (test->text value clause-length)
872 #:globals (.globals clause-info)))))
874 ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
875 (lambda (body-length)
877 (define (test->text value clause-length)
878 (append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
879 (jump-nz clause-length)))
880 (let* ((value (cstring->number value))
882 (clone info #:text (append (.text info) (test->text value 0))))
883 (text-length (length (.text test-info)))
884 (clause-info (let loop ((elements elements) (info test-info))
885 (if (null? elements) info
886 (loop (cdr elements) ((statement->info info body-length) (car elements))))))
887 (clause-text (list-tail (.text clause-info) text-length))
888 (clause-length (length (text->list clause-text))))
889 (clone info #:text (append
891 (test->text value clause-length)
893 #:globals (.globals clause-info)))))
895 ((default (compd-stmt (block-item-list . ,elements)))
896 (lambda (body-length)
897 (let ((text-length (length (.text info))))
898 (let loop ((elements elements) (info info))
899 (if (null? elements) info
900 (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
902 ((case (p-expr (ident ,constant)) ,statement)
903 ((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
905 ((case (p-expr (fixed ,value)) ,statement)
906 ((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
908 ((default ,statement)
909 ((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
911 (_ (stderr "no case match: ~a\n" o) barf)
914 (define (test->jump->info info)
917 (let* ((text (.text info))
918 (info (clone info #:text '()))
919 (info ((ast->info info) o))
920 (jump-text (lambda (body-length)
921 (list (lambda (f g ta t d) (type body-length))))))
922 (lambda (body-length)
926 (jump-text body-length)))))))
929 ((lt ,a ,b) ((jump i386:Xjump-nc) o))
930 ((gt ,a ,b) ((jump i386:Xjump-nc) o))
931 ((ne ,a ,b) ((jump i386:Xjump-nz) o))
932 ((eq ,a ,b) ((jump i386:Xjump-nz) o))
933 ((not _) ((jump i386:Xjump-z) o))
935 (let* ((text (.text info))
936 (info (clone info #:text '()))
938 (a-jump ((test->jump->info info) a))
939 (a-text (.text (a-jump 0)))
940 (a-length (length (text->list a-text)))
942 (b-jump ((test->jump->info info) b))
943 (b-text (.text (b-jump 0)))
944 (b-length (length (text->list b-text))))
946 (lambda (body-length)
949 (.text (a-jump (+ b-length body-length)))
950 (.text (b-jump body-length)))))))
952 (let* ((text (.text info))
953 (info (clone info #:text '()))
955 (a-jump ((test->jump->info info) a))
956 (a-text (.text (a-jump 0)))
957 (a-length (length (text->list a-text)))
959 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
960 (jump-length (length (text->list jump-text)))
962 (b-jump ((test->jump->info info) b))
963 (b-text (.text (b-jump 0)))
964 (b-length (length (text->list b-text)))
966 (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
968 (lambda (body-length)
971 (.text (a-jump jump-length))
973 (.text (b-jump body-length)))))))
974 ((array-ref . _) ((jump i386:jump-byte-z) o))
975 ((de-ref _) ((jump i386:jump-byte-z) o))
976 (_ ((jump i386:Xjump-z) o)))))
978 (define (cstring->number s)
979 (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
980 ((string-prefix? "0" s) (string->number s 8))
981 (else (string->number s))))
983 (define (struct-field o)
985 ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
986 (comp-declr-list (comp-declr (ident ,name))))
988 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
990 ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
992 ((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)))))))))
993 (cons type name)) ;; FIXME function / int
994 ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
995 (cons type name)) ;; FIXME: ptr/char
996 (_ (stderr "struct-field: no match: ~s\n" o) barf)))
998 (define (ast->type o)
1002 ((struct-ref (ident ,type))
1003 (list "struct" type))
1004 (_ (stderr "SKIP: type=~s\n" o)
1007 (define i386:type-alist
1008 '(("char" . (builtin 1 #f))
1009 ("int" . (builtin 4 #f))))
1011 (define (type->size info o)
1012 ;; (stderr "types=~s\n" (.types info))
1013 ;; (stderr "type->size o=~s => ~s\n" o (cadr (assoc-ref (.types info) o)))
1014 (cadr (assoc-ref (.types info) o)))
1016 (define (ident->decl info o)
1017 (stderr "ident->decl o=~s\n" o)
1018 ;; (stderr " types=~s\n" (.types info))
1019 ;; (stderr " local=~s\n" (assoc-ref (.locals info) o))
1020 ;; (stderr " global=~s\n" (assoc-ref (.globals info) o))
1021 (or (assoc-ref (.locals info) o)
1022 (assoc-ref (.globals info) o)
1024 (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
1025 (assoc-ref (.functions info) o))))
1027 (define (ident->type info o)
1028 (and=> (ident->decl info o) car))
1030 (define (ident->pointer info o)
1031 (let ((local (assoc-ref (.locals info) o)))
1032 (if local (local:pointer local)
1033 (or (and=> (ident->decl info o) global:pointer) 0))))
1035 (define (type->description info o)
1036 ;; (stderr "type->description =~s\n" o)
1037 ;; (stderr "types=~s\n" (.types info))
1038 ;; (stderr "type->description o=~s ==> ~s\n" o (caddr (assoc-ref (.types info) o)))
1039 ;; (stderr " assoc ~a\n" (assoc-ref (.types info) o))
1040 (caddr (assoc-ref (.types info) o)))
1042 (define (local? o) ;; formals < 0, locals > 0
1043 (positive? (local:id o)))
1045 (define (ast->info info)
1047 (let ((globals (.globals info))
1048 (locals (.locals info))
1049 (constants (.constants info))
1050 (text (.text info)))
1051 (define (add-local locals name type pointer)
1052 (let* ((id (1+ (length (filter local? (map cdr locals)))))
1053 (locals (cons (make-local name type pointer id) locals)))
1056 ;; (stderr "\n ast->info=~s\n" o)
1057 ;; (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)))
1058 ;; (stderr " text=~a\n" text)
1059 ;; (stderr " info=~a\n" info)
1060 ;; (stderr " globals=~a\n" globals)
1062 (((trans-unit . _) . _)
1063 ((ast-list->info info) o))
1064 ((trans-unit . ,elements)
1065 ((ast-list->info info) elements))
1066 ((fctn-defn . _) ((function->info info) o))
1067 ((comment . _) info)
1068 ((cpp-stmt (define (name ,name) (repl ,value)))
1071 ((cast (type-name (decl-spec-list (type-spec (void)))) _)
1074 ;; FIXME: expr-stmt wrapper?
1077 ((assn-expr . ,assn-expr)
1078 ((ast->info info) `(expr-stmt ,o)))
1081 (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
1084 ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
1086 ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
1087 (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
1088 (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
1089 (let* ((globals (append globals (filter-map expr->global expr-list)))
1090 (info (clone info #:globals globals))
1091 (text-length (length text))
1092 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1093 (if (null? expressions) info
1094 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1095 (text (.text args-info))
1096 (n (length expr-list)))
1097 (if ;;#t ;;(assoc-ref globals name)
1098 (not (equal? name "functionx"))
1099 (clone args-info #:text
1101 (list (lambda (f g ta t d)
1102 (i386:call f g ta t d (+ t (function-offset name f)) n))))
1104 (let* ((empty (clone info #:text '()))
1105 (accu ((expr->accu empty) `(p-expr (ident ,name)))))
1106 (stderr "DINGES: ~a\n" o)
1107 (clone args-info #:text
1110 (list (lambda (f g ta t d)
1111 (i386:call-accu f g ta t d n))))
1112 #:globals globals))))))
1114 ;;((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))))
1115 ((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
1116 (let* ((globals (append globals (filter-map expr->global expr-list)))
1117 (info (clone info #:globals globals))
1118 (text-length (length text))
1119 (args-info (let loop ((expressions (reverse expr-list)) (info info))
1120 (if (null? expressions) info
1121 (loop (cdr expressions) ((expr->arg info) (car expressions))))))
1122 (text (.text args-info))
1123 (n (length expr-list))
1124 (empty (clone info #:text '()))
1125 (accu ((expr->accu empty) function)))
1129 (list (lambda (f g ta t d)
1130 (i386:call-accu f g ta t d n))))
1131 #:globals globals)))
1134 (let* ((text-length (length text))
1136 (test-jump->info ((test->jump->info info) test))
1137 (test+jump-info (test-jump->info 0))
1138 (test-length (length (.text test+jump-info)))
1140 (body-info ((ast->info test+jump-info) body))
1141 (text-body-info (.text body-info))
1142 (body-text (list-tail text-body-info test-length))
1143 (body-length (length (text->list body-text)))
1145 (text+test-text (.text (test-jump->info body-length)))
1146 (test-text (list-tail text+test-text text-length)))
1152 #:globals (.globals body-info))))
1154 ((if ,test ,then ,else)
1155 (let* ((text-length (length text))
1157 (test-jump->info ((test->jump->info info) test))
1158 (test+jump-info (test-jump->info 0))
1159 (test-length (length (.text test+jump-info)))
1161 (then-info ((ast->info test+jump-info) then))
1162 (text-then-info (.text then-info))
1163 (then-text (list-tail text-then-info test-length))
1164 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1165 (then-jump-length (length (text->list then-jump-text)))
1166 (then-length (+ (length (text->list then-text)) then-jump-length))
1168 (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
1169 (else-info ((ast->info then+jump-info) else))
1170 (text-else-info (.text else-info))
1171 (else-text (list-tail text-else-info (length (.text then+jump-info))))
1172 (else-length (length (text->list else-text)))
1174 (text+test-text (.text (test-jump->info then-length)))
1175 (test-text (list-tail text+test-text text-length))
1176 (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1184 #:globals (append (.globals then-info)
1185 (list-tail (.globals else-info) (length globals))))))
1187 ((expr-stmt (cond-expr ,test ,then ,else))
1188 (let* ((text-length (length text))
1190 (test-jump->info ((test->jump->info info) test))
1191 (test+jump-info (test-jump->info 0))
1192 (test-length (length (.text test+jump-info)))
1194 (then-info ((ast->info test+jump-info) then))
1195 (text-then-info (.text then-info))
1196 (then-text (list-tail text-then-info test-length))
1197 (then-length (length (text->list then-text)))
1199 (jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
1200 (jump-length (length (text->list jump-text)))
1202 (test+then+jump-info
1204 #:text (append (.text then-info) jump-text)))
1206 (else-info ((ast->info test+then+jump-info) else))
1207 (text-else-info (.text else-info))
1208 (else-text (list-tail text-else-info (length (.text test+then+jump-info))))
1209 (else-length (length (text->list else-text)))
1211 (text+test-text (.text (test-jump->info (+ then-length jump-length))))
1212 (test-text (list-tail text+test-text text-length))
1213 (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
1221 #:globals (.globals else-info))))
1223 ((switch ,expr (compd-stmt (block-item-list . ,cases)))
1224 (let* ((expr ((expr->accu info) expr))
1225 (empty (clone info #:text '()))
1226 (case-infos (map (case->jump-info empty) cases))
1227 (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
1228 (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
1229 (if (null? cases) info
1230 (let ((c-j ((case->jump-info info) (car cases))))
1231 (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
1234 ((for ,init ,test ,step ,body)
1235 (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
1237 (info ((ast->info info) init))
1239 (init-text (.text info))
1240 (init-locals (.locals info))
1241 (info (clone info #:text '()))
1243 (body-info ((ast->info info) body))
1244 (body-text (.text body-info))
1245 (body-length (length (text->list body-text)))
1247 (step-info ((ast->info info) `(expr-stmt ,step)))
1248 (step-text (.text step-info))
1249 (step-length (length (text->list step-text)))
1251 (test-jump->info ((test->jump->info info) test))
1252 (test+jump-info (test-jump->info 0))
1253 (test-length (length (text->list (.text test+jump-info))))
1255 (skip-body-text (list (lambda (f g ta t d)
1256 (i386:Xjump (+ body-length step-length)))))
1258 (jump-text (list (lambda (f g ta t d)
1259 (i386:Xjump (- (+ body-length step-length test-length))))))
1260 (jump-length (length (text->list jump-text)))
1262 (test-text (.text (test-jump->info jump-length))))
1272 #:globals (append globals (list-tail (.globals body-info) (length globals)))
1275 ((while ,test ,body)
1276 (let* ((skip-info (lambda (body-length)
1277 (clone info #:text (append text
1278 (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
1279 (text (.text (skip-info 0)))
1280 (text-length (length text))
1282 (body-info (lambda (body-length)
1283 ((ast->info (skip-info body-length)) body)))
1284 (body-text (list-tail (.text (body-info 0)) text-length))
1285 (body-length (length (text->list body-text)))
1287 (body-info (body-info body-length))
1289 (empty (clone info #:text '()))
1290 (test-jump->info ((test->jump->info empty) test))
1291 (test+jump-info (test-jump->info 0))
1292 (test-length (length (text->list (.text test+jump-info))))
1294 (jump-text (list (lambda (f g ta t d)
1295 (i386:Xjump (- (+ body-length test-length))))))
1296 (jump-length (length (text->list jump-text)))
1298 (test-text (.text (test-jump->info jump-length))))
1304 #:globals (.globals body-info))))
1306 ((labeled-stmt (ident ,label) ,statement)
1307 (let ((info (clone info #:text (append text (list label)))))
1308 ((ast->info info) statement)))
1310 ((goto (ident ,label))
1311 (let* ((jump (lambda (n) (i386:XXjump n)))
1312 (offset (+ (length (jump 0)) (length (text->list text)))))
1315 (list (lambda (f g ta t d)
1316 (jump (- (label-offset (.function info) label f) offset))))))))
1318 ;;; FIXME: only zero?!
1319 ((p-expr (ident ,name))
1322 ((ident->accu info) name)
1323 (list (lambda (f g ta t d)
1325 (i386:accu-zero?)))))))
1327 ((p-expr (fixed ,value))
1328 (let ((value (cstring->number value)))
1331 (list (lambda (f g ta t d)
1333 (i386:value->accu value)
1334 (i386:accu-zero?))))))))
1336 ((de-ref (p-expr (ident ,name)))
1339 ((ident->accu info) name)
1340 (list (lambda (f g ta t d)
1342 (i386:byte-mem->accu)))))))
1344 ((fctn-call . ,call)
1345 (let ((info ((ast->info info) `(expr-stmt ,o))))
1347 (append (.text info)
1348 (list (lambda (f g ta t d)
1349 (i386:accu-zero?)))))))
1352 ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1353 ((post-inc (p-expr (ident ,name)))
1356 ((ident->accu info) name)
1357 ((ident-add info) name 1)
1358 (list (lambda (f g ta t d)
1360 (i386:accu-zero?)))))))
1361 ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1362 ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1363 ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
1364 ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
1367 ((expr-stmt (post-inc (p-expr (ident ,name))))
1368 (clone info #:text (append text ((ident-add info) name 1))))
1371 ((expr-stmt (pre-inc (p-expr (ident ,name))))
1372 (or (assoc-ref locals name) barf)
1375 ((ident-add info) name 1)
1376 ((ident->accu info) name)
1377 (list (lambda (f g ta t d)
1379 ;;(i386:local->accu (local:id (assoc-ref locals name)))
1380 (i386:accu-zero?)))))))
1383 ((expr-stmt (post-dec (p-expr (ident ,name))))
1384 (or (assoc-ref locals name) barf)
1387 ((ident->accu info) name)
1388 ((ident-add info) name -1)
1389 (list (lambda (f g ta t d)
1391 ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1392 (i386:accu-zero?)))))))
1395 ((expr-stmt (pre-dec (p-expr (ident ,name))))
1396 (or (assoc-ref locals name) barf)
1399 ((ident-add info) name -1)
1400 ((ident->accu info) name)
1401 (list (lambda (f g ta t d)
1403 ;;(i386:local-add (local:id (assoc-ref locals name)) -1)
1404 ;;(i386:local->accu (local:id (assoc-ref locals name)))
1405 (i386:accu-zero?)))))))
1408 (let* ((test-info ((ast->info info) expr)))
1410 (append (.text test-info)
1411 (list (lambda (f g ta t d)
1414 (i386:accu-zero?)))))
1415 #:globals (.globals test-info))))
1418 (let* ((base ((expr->base info) a))
1419 (empty (clone base #:text '()))
1420 (accu ((expr->accu empty) b)))
1425 (list (lambda (f g ta t d)
1426 (i386:sub-base)))))))
1429 (let* ((base ((expr->base info) a))
1430 (empty (clone base #:text '()))
1431 (accu ((expr->accu empty) b)))
1436 (list (lambda (f g ta t d)
1437 (i386:sub-base)))))))
1440 (let* ((base ((expr->base info) a))
1441 (empty (clone base #:text '()))
1442 (accu ((expr->accu empty) b)))
1447 (list (lambda (f g ta t d)
1450 (i386:xor-zf))))))))
1453 (let* ((base ((expr->base info) a))
1454 (empty (clone base #:text '()))
1455 (accu ((expr->accu empty) b)))
1460 (list (lambda (f g ta t d)
1461 (i386:base-sub)))))))
1463 ;; TODO: byte dinges
1465 (let* ((base ((expr->base info) a))
1466 (empty (clone base #:text '()))
1467 (accu ((expr->accu empty) b)))
1472 (list (lambda (f g ta t d)
1473 (i386:base-sub)))))))
1475 ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
1478 (list (lambda (f g ta t d)
1480 (i386:local->accu (local:id (assoc-ref locals a)))
1481 (i386:byte-mem->base)
1482 (i386:local->accu (local:id (assoc-ref locals b)))
1483 (i386:byte-mem->accu)
1484 (i386:byte-sub-base)))))))
1487 ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,array)))
1488 (let ((value (cstring->number value)))
1491 ((ident->base info) array)
1492 (list (lambda (f g ta t d)
1494 (i386:value->accu value)
1495 ;;(i386:byte-base-mem->accu)
1496 (i386:base-mem->accu)
1497 ))))))) ; FIXME: type: char
1500 ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
1503 ((ident->base info) index) ;; FIXME: chars! index*size
1504 ((ident->accu info) array)
1505 (list (lambda (f g ta t d)
1506 ;;(i386:byte-base-mem->accu)
1507 (i386:base-mem->accu)
1508 ))))) ; FIXME: type: char
1511 (let ((accu ((expr->accu info) expr)))
1513 (append (.text accu) (list (i386:ret (lambda _ '())))))))
1516 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
1517 (if (.function info)
1518 (clone info #:locals (add-local locals name type 0))
1519 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1522 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1523 (let ((value (cstring->number value)))
1524 (if (.function info)
1525 (let* ((locals (add-local locals name type 0))
1526 (info (clone info #:locals locals)))
1529 ((value->ident info) name value))))
1530 (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
1533 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
1534 (if (not (.function info)) decl-barf0)
1535 (let* ((locals (add-local locals name type 0))
1536 (info (clone info #:locals locals))
1537 (value (char->integer (car (string->list value)))))
1540 ((value->ident info) name value)))))
1543 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
1544 (if (not (.function info)) decl-barf1)
1545 (let* ((locals (add-local locals name type 0))
1546 (info (clone info #:locals locals))
1547 (value (- (cstring->number value))))
1550 ((value->ident info) name value)))))
1553 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1554 (if (not (.function info)) decl-barf2)
1555 (let* ((locals (add-local locals name type 0))
1556 (info (clone info #:locals locals)))
1559 ((ident->accu info) local)
1560 ((accu->ident info) name)))))
1563 ;;(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"))))))
1564 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
1565 (if (not (.function info)) decl-barf3)
1566 (let* ((locals (add-local locals name type 1))
1567 (globals (append globals (list (string->global string))))
1568 (info (clone info #:locals locals #:globals globals)))
1571 (list (lambda (f g ta t d)
1573 (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
1574 ((accu->ident info) name)))))
1576 ;; char arena[20000];
1577 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
1578 (let ((type (ast->type type)))
1579 (if (.function info)
1581 (let* ((globals (.globals info))
1582 (count (cstring->number count))
1583 (size (type->size info type))
1584 ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1585 (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
1586 (globals (append globals (list array))))
1588 #:globals globals)))))
1590 ;;struct scm *g_cells = (struct scm*)arena;
1591 ((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)))))))
1592 ;;(stderr "0TYPE: ~s\n" type)
1593 (if (.function info)
1594 (let* ((locals (add-local locals name type 1))
1595 (info (clone info #:locals locals)))
1598 ((ident->accu info) name)
1599 ((accu->ident info) value)))) ;; FIXME: deref?
1600 (let* ((globals (append globals (list (ident->global name type 1 0))))
1601 (info (clone info #:globals globals)))
1604 ((ident->accu info) name)
1605 ((accu->ident info) value)))))) ;; FIXME: deref?
1608 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
1609 ;;(stderr "1TYPE: ~s\n" type)
1610 (if (.function info)
1611 (clone info #:locals (add-local locals name type 0))
1612 (clone info #:globals (append globals (list (ident->global name type 0 0))))))
1615 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
1616 ;;(stderr "2TYPE: ~s\n" type)
1617 (if (.function info)
1618 (let* ((locals (add-local locals name type 0))
1619 (globals (append globals (list (string->global value))))
1620 (info (clone info #:locals locals #:globals globals)))
1623 (list (lambda (f g ta t d)
1625 (i386:global->accu (+ (data-offset value g) d)))))
1626 ((accu->ident info) name))))
1627 (let* ((value (length (globals->data globals)))
1628 (globals (append globals (list (ident->global name type 0 value)))))
1629 (clone info #:globals globals))))
1631 ;; SCM g_stack = 0; // comment
1632 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
1633 ((ast->info info) (list-head o (- (length o) 1))))
1636 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
1637 ;;(stderr "3TYPE: ~s\n" type)
1638 (if (.function info)
1639 (let* ((locals (add-local locals name type 0))
1640 (info (clone info #:locals locals)))
1643 ((ident->accu info) local)
1644 ((accu->ident info) name))))
1645 (let* ((globals (append globals (list (ident->global name type 0 0))))
1646 (info (clone info #:globals globals)))
1649 ((ident->accu info) local)
1650 ((accu->ident info) name))))))
1653 ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1654 ;;(stderr "4TYPE: ~s\n" type)
1655 (let* ((locals (add-local locals name type 0))
1656 (info (clone info #:locals locals)))
1657 (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1660 (append (.text info)
1661 ((accu->ident info) name))
1664 ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
1665 ((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))))
1666 (let* ((locals (add-local locals name type 1))
1667 (info (clone info #:locals locals))
1668 (empty (clone info #:text '()))
1669 (accu ((expr->accu empty) initzer)))
1674 ((accu->ident info) name)
1675 (list (lambda (f g ta t d)
1677 ;;(i386:value->base t)
1679 (i386:value->base ta)
1680 (i386:accu+base)))))
1684 ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
1685 ;;(stderr "5TYPE: ~s\n" type)
1686 (let* ((locals (add-local locals name type 0))
1687 (info (clone info #:locals locals)))
1688 (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
1691 (append (.text info)
1692 ((accu->ident info) name))))))
1694 ;; char *p = (char*)g_cells;
1695 ((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)))))))
1696 ;;(stderr "6TYPE: ~s\n" type)
1697 (if (.function info)
1698 (let* ((locals (add-local locals name type 1))
1699 (info (clone info #:locals locals)))
1702 ((ident->accu info) value)
1703 ((accu->ident info) name))))
1704 (let* ((globals (append globals (list (ident->global name type 1 0))))
1705 (here (data-offset name globals))
1706 (there (data-offset value globals)))
1709 #:init (append (.init info)
1710 (list (lambda (functions globals ta t d data)
1712 (list-head data here)
1714 ;;; char *x = arena;
1715 (int->bv32 (+ d (data-offset value globals)))
1717 ;;;(list-head (list-tail data there) 4)
1718 (list-tail data (+ here 4))))))))))
1720 ;; char *p = g_cells;
1721 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
1722 ;;(stderr "7TYPE: ~s\n" type)
1723 (let ((type (decl->type type)))
1724 ;;(stderr "0DECL: ~s\n" type)
1725 (if (.function info)
1726 (let* ((locals (add-local locals name type 1))
1727 (info (clone info #:locals locals)))
1730 ((ident->accu info) value)
1731 ((accu->ident info) name))))
1732 (let* ((globals (append globals (list (ident->global name type 1 0))))
1733 (here (data-offset name globals))
1734 (there (data-offset value globals)))
1737 #:init (append (.init info)
1738 (list (lambda (functions globals ta t d data)
1740 (list-head data here)
1742 ;;; char *x = arena;p
1743 (int->bv32 (+ d (data-offset value globals)))
1745 ;;;(list-head (list-tail data there) 4)
1746 (list-tail data (+ here 4)))))))))))
1749 ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
1750 (let ((type (enum->type name fields))
1751 (constants (map ident->constant (map cadadr fields) (iota (length fields)))))
1753 #:types (append (.types info) (list type))
1754 #:constants (append constants (.constants info)))))
1757 ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
1758 (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
1759 ;;(stderr "type: ~a\n" type)
1760 (clone info #:types (append (.types info) (list type)))))
1763 ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
1764 (when (not (equal? op "="))
1765 (stderr "OOOPS0.0: op=~s\n" op)
1767 (let* ((empty (clone info #:text '()))
1768 (base ((expr->base empty) b)))
1772 ((base->ident-address info) name)
1773 ((ident-add info) name 1)))))
1777 ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
1778 (when (not (equal? op "="))
1779 (stderr "OOOPS0: op=~s\n" op)
1781 (let* ((empty (clone info #:text '()))
1782 (expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
1783 (base ((expr->base empty) b))
1784 (type (list "struct" "scm")) ;; FIXME
1785 (fields (type->description info type))
1786 (size (type->size info type))
1787 (field-size 4) ;; FIXME:4, not fixed
1788 (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) )
1789 (clone info #:text (append text
1792 (list (lambda (f g ta t d)
1793 ;;(i386:byte-base->accu-ref) ;; FIXME: size
1794 (i386:base->accu-address)
1802 ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
1803 (when (and (not (equal? op "="))
1804 (not (equal? op "+="))
1805 (not (equal? op "-=")))
1806 (stderr "OOOPS1: op=~s\n" op)
1808 (let* ((empty (clone info #:text '()))
1809 (base ((expr->base empty) b)))
1810 (clone info #:text (append text
1812 (if (equal? op "=") '()
1813 (append ((ident->accu info) name)
1814 (list (lambda (f g ta t d)
1816 (if (equal? op "+=")
1819 (i386:accu->base))))))
1821 ((base->ident info) name)))))
1824 ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
1825 (when (not (equal? op "="))
1826 (stderr "OOOPS2: op=~s\n" op)
1828 (let* ((empty (clone info #:text '()))
1829 (base ((expr->base empty) b)))
1830 (clone info #:text (append text
1833 ((base->ident-address info) array)))))
1836 ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
1837 (when (not (equal? op "="))
1838 (stderr "OOOPS3: op=~s\n" op)
1840 (let* ((index (cstring->number index))
1841 (empty (clone info #:text '()))
1842 (base ((expr->base empty) b))
1843 (type (ident->type info array))
1844 (fields (or (type->description info type) '())) ;; FIXME: struct!
1845 (size (type->size info type))
1846 (count (length fields))
1847 (field-size 4) ;; FIXME:4, not fixed
1848 (ptr (ident->pointer info array)))
1852 (list (lambda (f g ta t d)
1854 (list (lambda (f g ta t d)
1856 (i386:value->base index)
1858 (if (> count 1) (i386:accu+accu) '())
1859 (if (= count 3) (i386:accu+base) '())
1860 (i386:accu-shl 2))))
1861 ((ident->base info) array)
1862 (list (lambda (f g tav t d)
1864 (list (lambda (f g ta t d)
1866 (cond ((equal? array "g_functions") ;; FIXME
1867 (list (lambda (f g ta t d)
1869 (i386:base-address->accu-address)
1872 (i386:base-address->accu-address)
1875 (i386:base-address->accu-address)))))
1876 (else (list (lambda (f g ta t d)
1877 (i386:base->accu-address)))))))))
1880 ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
1881 (stderr "g_cells4[]: ~s\n" array)
1882 ;;(stderr "pointer_cells4[]: ~s\n" array)
1883 (when (not (equal? op "="))
1884 (stderr "OOOPS4: op=~s\n" op)
1886 (let* ((empty (clone info #:text '()))
1887 (base ((expr->base empty) b))
1888 (type (ident->type info array))
1889 (fields (or (type->description info type) '())) ;; FIXME: struct!
1890 (size (type->size info type))
1891 (count (length fields))
1892 (field-size 4) ;; FIXME:4, not fixed
1893 (ptr (ident->pointer info array)))
1894 (stderr "g_cells4[~a]: type=~a\n" array type)
1895 (stderr "g_cells4[~a]: pointer=~a\n" array ptr)
1896 (stderr "g_cells4[~a]: fields=~a\n" array fields)
1897 (stderr "g_cells4[~a]: size=~a\n" array size)
1898 (stderr "g_cells4[~a]: count=~a\n" array count)
1902 (list (lambda (f g ta t d)
1904 ((ident->base info) index)
1905 (list (lambda (f g ta t d)
1908 (if (> count 1) (i386:accu+accu) '())
1909 (if (= count 3) (i386:accu+base) '())
1910 (i386:accu-shl 2))))
1911 ((ident->base info) array)
1912 (list (lambda (f g ta t d)
1914 (list (lambda (f g ta t d)
1916 (cond ((equal? array "g_functions") ;; FIXME
1917 (list (lambda (f g ta t d)
1919 (i386:base-address->accu-address)
1922 (i386:base-address->accu-address)
1925 (i386:base-address->accu-address)))))
1926 (else (list (lambda (f g ta t d)
1927 (i386:base->accu-address)))))))))
1929 ;; g_functions[g_function++] = g_foo;
1930 ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
1931 (when (not (equal? op "="))
1932 (stderr "OOOPS5: op=~s\n" op)
1934 (let* ((empty (clone info #:text '()))
1935 (base ((expr->base empty) b))
1936 (type (ident->type info array))
1937 (fields (or (type->description info type) '())) ;; FIXME: struct!
1938 (size (type->size info type))
1939 (count (length fields))
1940 (field-size 4) ;; FIXME:4, not fixed
1941 (ptr (ident->pointer info array)))
1942 (stderr "g_cells5[~a]: type=~a\n" array type)
1943 (stderr "g_cells5[~a]: pointer=~a\n" array ptr)
1944 (stderr "g_cells5[~a]: fields=~a\n" array fields)
1945 (stderr "g_cells5[~a]: size=~a\n" array size)
1946 (stderr "g_cells5[~a]: count=~a\n" array count)
1950 (list (lambda (f g ta t d)
1952 ((ident->base info) index)
1953 (list (lambda (f g ta t d)
1956 (if (> count 1) (i386:accu+accu) '())
1957 (if (= count 3) (i386:accu+base) '())
1958 (i386:accu-shl 2))))
1959 ((ident->base info) array)
1960 (list (lambda (f g ta t d)
1962 (list (lambda (f g ta t d)
1965 (cond ((equal? array "g_functions") ;; FIXME
1966 (list (lambda (f g ta t d)
1968 (i386:base-address->accu-address)
1971 (i386:base-address->accu-address)
1974 (i386:base-address->accu-address)))))
1975 (else (list (lambda (f g ta t d)
1976 (i386:base->accu-address)))))
1977 ((ident-add info) index 1)))))
1981 ;; struct f = {...};
1982 ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
1983 (let* ((type (decl->type type))
1984 ;;(foo (stderr "1DECL: ~s\n" type))
1985 (fields (type->description info type))
1986 (size (type->size info type))
1987 (field-size 4)) ;; FIXME:4, not fixed
1988 ;;(stderr "7TYPE: ~s\n" type)
1989 (if (.function info)
1990 (let* ((globals (append globals (filter-map initzer->global initzers)))
1991 (locals (let loop ((fields (cdr fields)) (locals locals))
1992 (if (null? fields) locals
1993 (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
1994 (locals (add-local locals name type -1))
1995 (info (clone info #:locals locals #:globals globals))
1996 (empty (clone info #:text '())))
1997 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
1998 (if (null? fields) info
1999 (let ((offset (* field-size (car fields)))
2000 (initzer (car initzers)))
2001 (loop (cdr fields) (cdr initzers)
2005 ((ident->accu info) name)
2006 (list (lambda (f g ta t d)
2008 (i386:accu->base))))
2009 (.text ((expr->accu empty) initzer))
2010 (list (lambda (f g ta t d)
2011 (i386:accu->base-address+n offset))))))))))
2012 (let* ((globals (append globals (filter-map initzer->global initzers)))
2013 (global (make-global name type -1 (string->list (make-string size #\nul))))
2014 (globals (append globals (list global)))
2015 (here (data-offset name globals))
2016 (info (clone info #:globals globals))
2018 (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
2019 (if (null? fields) info
2020 (let ((offset (* field-size (car fields)))
2021 (initzer (car initzers)))
2022 (loop (cdr fields) (cdr initzers)
2026 (list (lambda (functions globals ta t d data)
2028 (list-head data (+ here offset))
2029 (initzer->data info functions globals ta t d (car initzers))
2030 (list-tail data (+ here offset field-size)))))))))))))))
2033 (format (current-error-port) "SKIP: decl statement=~s\n" o)
2037 (format (current-error-port) "SKIP: statement=~s\n" o)
2041 (define (initzer->data info functions globals ta t d o)
2043 ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
2044 ((initzer (ref-to (p-expr (ident ,name))))
2045 ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
2046 (int->bv32 (+ ta (function-offset name functions))))
2047 ((initzer (p-expr (ident ,name)))
2048 (let ((value (assoc-ref (.constants info) name)))
2050 ((initzer (p-expr (string ,string)))
2051 (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
2052 (_ (stderr "initzer->data:SKIP: ~s\n" o)
2056 (define (info->exe info)
2057 (display "dumping elf\n" (current-error-port))
2058 (map write-any (make-elf (.functions info) (.globals info) (.init info))))
2060 (define (.formals o)
2062 ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
2063 ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
2064 (_ (format (current-error-port) ".formals: no match: ~a\n" o)
2067 (define (formal->text n)
2073 (define (formals->text o)
2075 ((param-list . ,formals)
2076 (let ((n (length formals)))
2077 (list (lambda (f g ta t d)
2079 (i386:function-preamble)
2080 (append-map (formal->text n) formals (iota n))
2081 (i386:function-locals))))))
2082 (_ (format (current-error-port) "formals->text: no match: ~a\n" o)
2085 (define (formals->locals o)
2087 ((param-list . ,formals)
2088 (let ((n (length formals)))
2089 (map make-local (map .name formals) (map .type formals) (make-list n 0) (iota n -2 -1))))
2090 (_ (format (current-error-port) "formals->info: no match: ~a\n" o)
2093 (define (function->info info)
2096 ;;(stderr "formals=~a\n" (.formals o))
2097 (let* ((name (.name o))
2098 (text (formals->text (.formals o)))
2099 (locals (formals->locals (.formals o))))
2100 (format (current-error-port) "compiling ~a\n" name)
2101 ;;(stderr "locals=~a\n" locals)
2102 (let loop ((statements (.statements o))
2103 (info (clone info #:locals locals #:function (.name o) #:text text)))
2104 (if (null? statements) (clone info
2106 #:functions (append (.functions info) (list (cons name (.text info)))))
2107 (let* ((statement (car statements)))
2108 (loop (cdr statements)
2109 ((ast->info info) (car statements)))))))))
2111 (define (ast-list->info info)
2113 (let loop ((elements elements) (info info))
2114 (if (null? elements) info
2115 (loop (cdr elements) ((ast->info info) (car elements)))))))
2119 (string-append ".byte"
2120 " 0x89 0xe8" ; mov %ebp,%eax
2121 " 0x83 0xc0 0x08" ; add $0x8,%eax
2123 " 0x89 0xe8" ; mov %ebp,%eax
2124 " 0x83 0xc0 0x04" ; add $0x4,%eax
2125 " 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
2128 (ast (with-input-from-string
2130 (string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
2135 (let* ((ast (with-input-from-string
2138 strlen (char const* s)
2150 (let* ((ast (with-input-from-string
2156 int r = read (g_stdin, &c1, 1);
2157 //int r = read (0, &c1, 1);
2158 if (r < 1) return -1;
2167 (let* ((ast (with-input-from-string
2172 //write (STDOUT, s, strlen (s));
2173 //int i = write (STDOUT, s, strlen (s));
2174 write (1, (char*)&c, 1);
2183 (let* ((ast (with-input-from-string
2186 eputs (char const* s)
2188 //write (STDERR, s, strlen (s));
2189 //write (2, s, strlen (s));
2200 (let* ((ast (with-input-from-string
2203 fputs (char const* s, int fd)
2215 (let* ((ast (with-input-from-string
2218 puts (char const* s)
2220 //write (STDOUT, s, strlen (s));
2221 //int i = write (STDOUT, s, strlen (s));
2232 (let* ((ast (with-input-from-string
2235 strcmp (char const* a, char const* b)
2237 while (*a && *b && *a == *b)
2250 (cons "exit" (list i386:exit))
2251 (cons "open" (list i386:open))
2252 (cons "read" (list i386:read))
2253 (cons "write" (list i386:write))))
2266 (let* ((ast (mescc))
2268 #:functions i386:libc
2269 #:types i386:type-alist))
2270 (ast (append libc ast))
2271 (info ((ast->info info) ast))
2272 (info ((ast->info info) _start)))