artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Support switch.

Browse source 
* module/language/c99/compiler.mes (case->jump-info): New function.
  (ast->info): Use it.
* doc/examples/t.c (swits): Test it.
This commit is contained in:
Jan Nieuwenhuizen 2017-01-17 19:03:08 +01:00
parent 04218971c5
commit 11f7f67a45
6 changed files with 613 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
guile/mescc.scm
View file

@ -1,6 +1,6 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-scheme-*-
export GUILE_AUTO_COMPILE=0 export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0}
exec ${GUILE-guile} -L $(pwd)/guile -e '(mescc)' -s "$0" "$@" exec ${GUILE-guile} -L $(pwd)/guile -e '(mescc)' -s "$0" "$@"
!# !#

472
module/language/c99/compiler.mes
View file

@ -54,7 +54,7 @@
("__GNUC__" . "0") ("__GNUC__" . "0")
("__NYACC__" . "1") ("__NYACC__" . "1")
("VERSION" . "0.4") ("VERSION" . "0.4")
("PREFIX" . "") ("PREFIX" . "\"\"")
) )
#:xdef? gnuc-xdef? #:xdef? gnuc-xdef?
#:mode 'code #:mode 'code
@ -169,6 +169,8 @@
(lambda (f g t d) (lambda (f g t d)
(i386:push-global (+ (data-offset o g) d))))) (i386:push-global (+ (data-offset o g) d)))))
(define push-global-de-ref push-global)
(define (push-ident globals locals) (define (push-ident globals locals)
(lambda (o) (lambda (o)
(let ((local (assoc-ref locals o))) (let ((local (assoc-ref locals o)))
@ -181,33 +183,68 @@
(if local (i386:push-local-ref local) (if local (i386:push-local-ref local)
((push-global-ref globals) o))))) ((push-global-ref globals) o)))))
(define (push-ident-de-ref globals locals)
(lambda (o)
(let ((local (assoc-ref locals o)))
(if local (i386:push-local-de-ref local)
((push-global-de-ref globals) o)))))
(define (expr->arg info) ;; FIXME: get Mes curried-definitions (define (expr->arg info) ;; FIXME: get Mes curried-definitions
(lambda (o) (lambda (o)
(pmatch o (pmatch o
((p-expr (fixed ,value)) (cstring->number value)) ((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
((p-expr (string ,string)) ((push-global-ref (.globals info)) string)) ((p-expr (string ,string)) ((push-global-ref (.globals info)) string))
((p-expr (ident ,name)) ((p-expr (ident ,name))
((push-ident (.globals info) (.locals info)) name)) ((push-ident (.globals info) (.locals info)) name))
((array-refo (p-expr (fixed ,value)) (p-expr (ident ,name))) ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
(let ((value (cstring->number value)) (let ((value (cstring->number value))
(size 4)) ;; FIXME: type: int (size 4)) ;; FIXME: type: int
(lambda (f g t d)
(append (append
((ident->base (.locals info)) name) ((ident->base (.locals info)) name)
(list
(lambda (f g t d)
(append
(i386:value->accu (* size value)) ;; FIXME: type: int (i386:value->accu (* size value)) ;; FIXME: type: int
(i386:base-mem->accu) ;; FIXME: type: int (i386:base-mem->accu) ;; FIXME: type: int
(i386:push-accu) ;; hmm (i386:push-accu) ;; hmm
)))) ))))))
((de-ref (p-expr (ident ,name)))
(lambda (f g t d)
((push-ident-de-ref (.globals info) (.locals info)) name)))
((ref-to (p-expr (ident ,name))) ((ref-to (p-expr (ident ,name)))
(lambda (f g t d) (lambda (f g t d)
((push-ident-ref (.globals info) (.locals info)) name))) ((push-ident-ref (.globals info) (.locals info)) name)))
;; f (car (x))
((fctn-call . ,call)
(let ((info ((ast->info info) o)))
(append (.text info)
(list
(lambda (f g t d)
(i386:push-accu))))))
;; f (CAR (x))
((d-sel . ,d-sel)
(let* ((empty (clone info #:text '()))
(expr ((expr->accu empty) `(d-sel ,@d-sel))))
(append (.text expr)
(list (lambda (f g t d)
(i386:push-accu))))))
;; f (0 + x)
;;; aargh
;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
((cast (type-name (decl-spec-list (type-spec (fixed-type _))) ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
(abs-declr (pointer))) (abs-declr (pointer)))
,cast) ,cast)
((expr->arg info) cast)) ((expr->arg info) cast))
(_ (_
(format (current-error-port) "SKIP expr->arg=~a\n" o) (format (current-error-port) "SKIP expr->arg=~s\n" o)
0)))) 0))))
(define (ident->accu info) (define (ident->accu info)
@ -215,7 +252,9 @@
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (if local
(list (lambda (f g t d) (list (lambda (f g t d)
(i386:local->accu local))) (if (equal? o "c1")
(i386:byte-local->accu local) ;; FIXME
(i386:local->accu local))))
(list (lambda (f g t d) (list (lambda (f g t d)
(i386:global->accu (+ (data-offset o g) d)))))))) (i386:global->accu (+ (data-offset o g) d))))))))
@ -264,9 +303,108 @@
((not (fctn-call . _)) ((ast->info info) o)) ((not (fctn-call . _)) ((ast->info info) o))
((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
((neg (p-expr (fixed ,value))) (- (cstring->number value))) ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
;; g_cells[10].type
((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
(let* ((struct-type "scm") ;; FIXME
(struct (assoc-ref (.types info) struct-type))
(size (length struct))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
(index (cstring->number index))
(text (.text info)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:value->base index)
(i386:base->accu)
(if (> size 1) (i386:accu+accu) '())
(if (= size 3) (i386:accu+base) '())
(i386:accu-shl 2)
;;;'(#x58 #x58)
)))
((ident->base info) array)
(list (lambda (f g t d)
(i386:accu+base)))))))
;; g_cells[x].type
((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
(let* ((struct-type "scm") ;; FIXME
(struct (assoc-ref (.types info) struct-type))
(size (length struct))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info)))
(clone info #:text
(append text
((ident->base info) index)
(list (lambda (f g t d)
(append
(i386:base->accu)
(if (> size 1) (i386:accu+accu) '())
(if (= size 3) (i386:accu+base) '())
(i386:accu-shl 2))))
((ident->base info) array)
(list (lambda (f g t d)
(i386:base-mem+n->accu offset)
;;(i386:accu+base)
))))))
(_ (_
(format (current-error-port) "SKIP expr->accu=~a\n" o) (format (current-error-port) "SKIP expr->accu=~s\n" o)
0) info)
)))
(define (expr->Xaccu info)
(lambda (o)
(pmatch o
;; g_cells[10].type
((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
(let* ((struct-type "scm") ;; FIXME
(struct (assoc-ref (.types info) struct-type))
(size (length struct))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
(index (cstring->number index))
(text (.text info)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:value->base index)
(i386:base->accu)
(if (> size 1) (i386:accu+accu) '())
(if (= size 3) (i386:accu+base) '())
(i386:accu-shl 2))))
((ident->base info) array)
(list (lambda (f g t d)
(i386:accu+base)))))))
;; g_cells[x].type
((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
(let* ((struct-type "scm") ;; FIXME
(struct (assoc-ref (.types info) struct-type))
(size (length struct))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info)))
(clone info #:text
(append text
((ident->base info) index)
(list (lambda (f g t d)
(append
(i386:base->accu)
(if (> size 1) (i386:accu+accu) '())
(if (= size 3) (i386:accu+base) '())
(i386:accu-shl 2))))
((ident->base info) array)
(list (lambda (f g t d)
(i386:accu+base)))))))
(_
(format (current-error-port) "SKIP expr->Xaccu=~s\n" o)
info)
))) )))
(define (string->global string) (define (string->global string)
@ -294,10 +432,69 @@
(define (asm->hex o) (define (asm->hex o)
(let ((prefix ".byte ")) (let ((prefix ".byte "))
(if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'()) (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
(let ((s (string-drop o (string-length prefix)))) (let ((s (string-drop o (string-length prefix))))
(map byte->hex (string-split s #\space)))))) (map byte->hex (string-split s #\space))))))
(define (case->jump-info info)
(define (jump n)
(list (lambda (f g t d) (i386:Xjump n))))
(define (jump-nz n)
(list (lambda (f g t d) (i386:Xjump-nz n))))
(define (statement->info info body-length)
(lambda (o)
(pmatch o
((break) (clone info #:text (append (.text info) (jump body-length)
)))
(_
((ast->info info) o)))))
(lambda (o)
(pmatch o
((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(let* ((value (assoc-ref (.constants info) constant))
(text-length (length (.text info)))
(clause-info (let loop ((elements elements) (info info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))
(clause-text (list-tail (.text clause-info) text-length))
(clause-length (length (text->list clause-text))))
(stderr "clause text[~a]: ~a\n" clause-length (map dec->hex (text->list clause-text)))
(clone info #:text (append
(.text info)
(list (lambda (f g t d) (i386:accu-cmp-value value)))
(jump-nz clause-length)
clause-text)
#:globals (.globals clause-info)))))
((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(let* ((value (cstring->number value))
(text-length (length (.text info)))
(clause-info (let loop ((elements elements) (info info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))
(clause-text (list-tail (.text clause-info) text-length))
(clause-length (length (text->list clause-text))))
(stderr "clause text[~a]: ~a\n" clause-length (map dec->hex (text->list clause-text)))
(clone info #:text (append
(.text info)
(list (lambda (f g t d) (i386:accu-cmp-value value)))
(jump-nz clause-length)
clause-text)
#:globals (.globals clause-info)))))
((default (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(let ((text-length (length (.text info))))
(let loop ((elements elements) (info info))
(if (null? elements) (let ((clause-text (list-tail (.text info) text-length)))
(stderr "default text[~a]: ~a\n" (length (text->list clause-text)) (map dec->hex (text->list clause-text)))
info)
(loop (cdr elements) ((statement->info info body-length) (car elements))))))))
(_ (stderr "no case match: ~a\n" o) barf)
)))
(define (test->jump->info info) (define (test->jump->info info)
(define (jump type) (define (jump type)
(lambda (o) (lambda (o)
@ -340,8 +537,20 @@
(_ ((jump i386:jump-z) o))))) (_ ((jump i386:jump-z) o)))))
(define (cstring->number s) (define (cstring->number s)
(if (string-prefix? "0" s) (string->number s 8) (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
(string->number s))) ((string-prefix? "0" s) (string->number s 8))
(else (string->number s))))
(define (struct-field o)
(pmatch o
((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
(comp-declr-list (comp-declr (ident ,name))))
(cons type name))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
(cons type name))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
(cons type name))
(_ (stderr "struct-field: no match: ~a" o) barf)))
(define (ast->info info) (define (ast->info info)
(lambda (o) (lambda (o)
@ -438,6 +647,20 @@
else-text) else-text)
#:globals (.globals else-info)))) #:globals (.globals else-info))))
((switch ,expr (compd-stmt (block-item-list . ,cases)))
(let* ((accu ((expr->accu info) expr))
(expr (if (info? accu) accu ;; AAARGH
(clone info #:text
(append text (list accu)))))
(empty (clone info #:text '()))
(case-infos (map (case->jump-info empty) cases))
(case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
(cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
(if (null? cases) info
(let ((c-j ((case->jump-info info) (car cases))))
(loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
cases-info))
((for ,init ,test ,step ,body) ((for ,init ,test ,step ,body)
(let* ((info (clone info #:text '())) (let* ((info (clone info #:text '()))
@ -711,6 +934,17 @@
(i386:sub-base) (i386:sub-base)
(i386:xor-zf)))))))) (i386:xor-zf))))))))
((ne (p-expr (ident ,a)) (p-expr (char ,b)))
(let ((b (char->integer (car (string->list b)))))
(clone info #:text
(append text
((ident->base info) a)
(list (lambda (f g t d)
(append
(i386:value->accu b)
(i386:sub-base)
(i386:xor-zf))))))))
((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b)))) ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
(let ((b (- (cstring->number b)))) (let ((b (- (cstring->number b))))
(clone info #:text (clone info #:text
@ -722,6 +956,17 @@
(i386:sub-base) (i386:sub-base)
(i386:xor-zf)))))))) (i386:xor-zf))))))))
((ne (p-expr (ident ,a)) (p-expr (ident ,constant)))
(let ((b (assoc-ref (.constants info) constant)))
(clone info #:text
(append text
((ident->base info) a)
(list (lambda (f g t d)
(append
(i386:value->accu b)
(i386:sub-base)
(i386:xor-zf))))))))
((ne (fctn-call . ,call) (p-expr (fixed ,b))) ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
(let ((b (cstring->number b)) (let ((b (cstring->number b))
(info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
@ -757,6 +1002,46 @@
(i386:byte-test-base) (i386:byte-test-base)
(i386:xor-zf))))))) (i386:xor-zf)))))))
((ne (de-ref (p-expr (ident ,a))) (p-expr (char ,b)))
(let ((b (char->integer (car (string->list b)))))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local->accu (assoc-ref locals a))
(i386:byte-mem->base)
;;(i386:local->accu (assoc-ref locals b))
;;(i386:byte-mem->accu)
(i386:value->accu b)
(i386:byte-test-base)
(i386:xor-zf))))))))
;; CAR (x) != 1 // cell_nil
((ne (d-sel . ,d-sel) (p-expr (fixed ,b)))
(let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
(b (cstring->number b)))
(clone info #:text
(append text
(.text expr)
(list (lambda (f g t d)
(append
(i386:value->base b)
(i386:sub-base)
(i386:xor-zf))))))))
;; CAR (x) != PAIR
((ne (d-sel . ,d-sel) (p-expr (ident ,constant)))
(let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
(b (assoc-ref (.constants info) constant)))
(clone info #:text
(append text
(.text expr)
(list (lambda (f g t d)
(append
(i386:value->base b)
(i386:sub-base)
(i386:xor-zf))))))))
((lt (p-expr (ident ,a)) (p-expr (fixed ,b))) ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
(let ((b (cstring->number b))) (let ((b (cstring->number b)))
(clone info #:text (clone info #:text
@ -815,6 +1100,24 @@
(clone info #:text (clone info #:text
(append text ((value->ident info) name value)))))) (append text ((value->ident info) name value))))))
;; int i = 0;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
(let* ((locals (add-local name))
(info (clone info #:locals locals))
(value (cstring->number value)))
(clone info #:text
(append text
((value->ident info) name value)))))
;; int i = -1;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
(let* ((locals (add-local name))
(info (clone info #:locals locals))
(value (- (cstring->number value))))
(clone info #:text
(append text
((value->ident info) name value)))))
;; int i = argc; ;; int i = argc;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local)))))) ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
(let* ((locals (add-local name)) (let* ((locals (add-local name))
@ -837,6 +1140,25 @@
(i386:global->accu (+ (data-offset value g) d))))) (i386:global->accu (+ (data-offset value g) d)))))
((accu->ident info) name))))) ((accu->ident info) name)))))
;; char arena[20000];
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
(let* ((globals (.globals info))
(count (cstring->number count))
(size 1) ;; FIXME
(array (list (ident->global name 0))) ;;FIXME: deref?
(dummy (list (cons (string->list "dummy")
(string->list (make-string (* count size) #\nul))))))
(clone info #:globals (append globals array dummy))))
;;struct scm *g_cells = (struct scm*)arena;
((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)))))))
(let* ((locals (add-local name))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) name)
((accu->ident info) value))))) ;; FIXME: deref?
;; SCM g_stack = 0; ;; SCM g_stack = 0;
((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _)) ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
((ast->info info) (list-head o (- (length o) 1)))) ((ast->info info) (list-head o (- (length o) 1))))
@ -886,6 +1208,24 @@
(append (.text info) (append (.text info)
((accu->ident info) name)))))) ((accu->ident info) name))))))
;; char *p = (char*)g_cells;
((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)))))))
(let* ((locals (add-local name))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) value)
((accu->ident info) name)))))
;; char *p = g_cells;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
(let* ((locals (add-local name))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) value)
((accu->ident info) name)))))
;; enum ;; enum
((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields))))) ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
(let ((type (ident->type name "enum")) (let ((type (ident->type name "enum"))
@ -893,6 +1233,11 @@
(clone info #:types (append (.types info) (list type)) (clone info #:types (append (.types info) (list type))
#:constants (append constants (.constants info))))) #:constants (append constants (.constants info)))))
;; struct
((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
(let* ((type (ident->type name (map struct-field fields))))
(clone info #:types (append (.types info) (list type)))))
;; i = 0; ;; i = 0;
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))) ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name)) ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
@ -908,6 +1253,101 @@
(let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
(clone info #:text (append (.text info) ((accu->ident info) name))))) (clone info #:text (append (.text info) ((accu->ident info) name)))))
;; p = g_cell;
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (ident ,value))))
(clone info #:text
(append text
((ident->accu info) value)
((accu->ident info) name))))
;; *p++ = c;
((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op _) (p-expr (ident ,value))))
(let* ((locals (add-local name))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) value)
((accu->ident info) name)
(list (lambda (f g t d)
(i386:local-add (assoc-ref locals name) 1)))))))
((d-sel . ,d-sel)
(let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
expr))
;; i = CAR (x)
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (d-sel . ,d-sel)))
(let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
(clone info #:text (append (.text expr)
((accu->ident info) name)))))
;; TYPE (x) = PAIR;
;; ((expr-stmt (assn-expr (d-sel . ,d-sel) (op _) (p-expr (ident ,constant))))
;; (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
;; (b (assoc-ref (.constants info) constant)))
;; (clone info #:text (append (.text expr)
;; (list (lambda (f g t d)
;; (i386:accu+base)
;; (i386:value->accu-ref b)))))))
((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (ident ,constant))))
(let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
(b (assoc-ref (.constants info) constant))
(struct-type "scm") ;; FIXME
(struct (assoc-ref (.types info) struct-type))
(size (length struct))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))))
(clone info #:text (append (.text expr)
(list (lambda (f g t d)
(i386:value->accu-ref+n offset b)))))))
;; CAR (x) = 0
;; ((expr-stmt (assn-expr (d-sel . ,d-sel) (op _) (p-expr (fixed ,value))))
;; (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
;; (b (cstring->number value)))
;; (clone info #:text (append (.text expr)
;; (list (lambda (f g t d)
;; (i386:accu+base)
;; (i386:value->accu-ref b)))))))
((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (fixed ,value))))
(let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
(b (cstring->number value))
(struct-type "scm") ;; FIXME
(struct (assoc-ref (.types info) struct-type))
(size (length struct))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))) )
(clone info #:text (append (.text expr)
(list (lambda (f g t d)
(i386:value->accu-ref+n offset b)))))))
;; g_cells[0] = 65;
((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
(let ((index (cstring->number index))
(value (cstring->number value)))
(clone info #:text
(append text
((ident->base info) name)
((ident->accu info) index)
(list (lambda (f g t d)
(i386:accu+base)
(i386:value->accu-ref value)))))))
((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (char ,value))))
(let ((index (cstring->number index))
(value (char->integer (car (string->list value)))))
(clone info #:text
(append text
((ident->base info) name)
((ident->accu info) index)
(list (lambda (f g t d)
(i386:accu+base)
(i386:value->accu-ref value)))))))
(_ (_
(format (current-error-port) "SKIP statement=~s\n" o) (format (current-error-port) "SKIP statement=~s\n" o)
info))))) info)))))
@ -1012,11 +1452,11 @@ strlen (char const* s)
int int
getchar () getchar ()
{ {
char c; char c1;
int r = read (g_stdin, &c, 1); int r = read (g_stdin, &c1, 1);
//int r = read (0, &c, 1); //int r = read (0, &c1, 1);
if (r < 1) return -1; if (r < 1) return -1;
return c; return c1;
} }
" "
;;paredit:" ;;paredit:"
@ -1125,7 +1565,7 @@ strcmp (char const* a, char const* b)
(define (compile) (define (compile)
(let* ((ast (mescc)) (let* ((ast (mescc))
(info (make <info> #:functions i386:libc)) (info (make <info> #:functions i386:libc))
(info ((ast->info info) libc)) (ast (append libc ast))
(info ((ast->info info) ast)) (info ((ast->info info) ast))
(info ((ast->info info) _start))) (info ((ast->info info) _start)))
(info->exe info))) (info->exe info)))

11
module/mes/elf-util.mes
View file

@ -50,10 +50,15 @@
(define (function-prefix name functions) (define (function-prefix name functions)
(member name (reverse functions) (lambda (a b) (equal? (car b) name)))) (member name (reverse functions) (lambda (a b) (equal? (car b) name))))
(define (function-offset name functions) (define function-offset
(let ((prefix (function-prefix name functions))) (let ((cache '()))
(if prefix (length (functions->text (cdr prefix) '() 0 0)) (lambda (name functions)
(or (assoc-ref cache name)
(let* ((prefix (function-prefix name functions))
(offset (if prefix (length (functions->text (cdr prefix) '() 0 0))
0))) 0)))
(if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset)))
offset)))))
(define (label-offset function label functions) (define (label-offset function label functions)
(let ((prefix (function-prefix function functions))) (let ((prefix (function-prefix function functions)))

66
module/mes/libc-i386.mes
View file

@ -32,9 +32,11 @@
'(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars '(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars
(define (i386:push-global-ref o) (define (i386:push-global-ref o)
(or o push-global-ref)
`(#x68 ,@(int->bv32 o))) ; push $0x<o> `(#x68 ,@(int->bv32 o))) ; push $0x<o>
(define (i386:push-global o) (define (i386:push-global o)
(or o push-global)
`(#xa1 ,@(int->bv32 o) ; mov 0x804a000,%eax `(#xa1 ,@(int->bv32 o) ; mov 0x804a000,%eax
#x50)) ; push %eax #x50)) ; push %eax
@ -47,13 +49,23 @@
`(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x<n>(%ebp),%eax `(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x<n>(%ebp),%eax
#x50)) ; push %eax #x50)) ; push %eax
(define (i386:push-local-de-ref n)
(or n push-local-de-ref)
`(#x8b #x45 ,(- 0 (* 4 n)) ; mov -0x<n>(%ebp),%eax
#x0f #xb6 #x00 ; movzbl (%eax),%eax
;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE****
#x50)) ; push %eax
(define (i386:push-accu) (define (i386:push-accu)
`(#x50)) ; push %eax `(#x50)) ; push %eax
(define (i386:push-arg f g t d) (define (i386:push-arg f g t d)
(lambda (o) (lambda (o)
(or o push-arg)
(cond ((number? o) (cond ((number? o)
`(#x68 ,@(int->bv32 o))) ; push $<o> `(#x68 ,@(int->bv32 o))) ; push $<o>
((and (pair? o) (procedure? (car o)))
(append-map (lambda (p) (p f g t d)) o))
((pair? o) o) ((pair? o) o)
((procedure? o) (o f g t d)) ((procedure? o) (o f g t d))
(_ barf)))) (_ barf))))
@ -81,23 +93,43 @@
`(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0 `(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0
(define (i386:accu-zero?) (define (i386:accu-zero?)
`(#x85 #xc0)) ; cmpl %eax,%eax '(#x85 #xc0)) ; cmpl %eax,%eax
(define (i386:accu-non-zero?) (define (i386:accu-non-zero?)
(append '(#x85 #xc0) ; cmpl %eax,%eax (append '(#x85 #xc0) ; cmpl %eax,%eax
(i386:xor-zf))) (i386:xor-zf)))
(define (i386:accu-shl n)
`(#xc1 #xe0 ,n)) ; shl $0x8,%eax
(define (i386:accu+accu)
'(#x01 #xc0)) ; add %eax,%eax
(define (i386:accu+base)
`(#x01 #xd0)) ; add %edx,%eax
(define (i386:base->accu)
'(#x89 #xd0)) ; mov %edx,%eax
(define (i386:local->accu n) (define (i386:local->accu n)
(or n local->accu) (or n local->accu)
`(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax `(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax
(define (i386:byte-local->accu n)
(or n local->accu)
`(#x0f #xb6 #x45 ,(- 0 (* 4 n)))) ; movzbl 0x<n>(%ebp),%eax
(define (i386:local->base n) (define (i386:local->base n)
(or n local->base) (or n local->base)
`(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx `(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx
(define (i386:global-ref->base n)
(or n global->base)
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0x<n>,%edx
(define (i386:global->base n) (define (i386:global->base n)
(or n global->base) (or n global->base)
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0xn,%edx `(#xba ,@(int->bv32 n))) ; mov $<n>,%edx
(define (i386:byte-base-mem->accu) (define (i386:byte-base-mem->accu)
'(#x01 #xd0 ; add %edx,%eax '(#x01 #xd0 ; add %edx,%eax
@ -113,12 +145,28 @@
'(#x01 #xd0 ; add %edx,%eax '(#x01 #xd0 ; add %edx,%eax
#x8b #x00)) ; mov (%eax),%eax #x8b #x00)) ; mov (%eax),%eax
(define (i386:base-mem+n->accu n)
`(#x01 #xd0 ; add %edx,%eax
#x8b #x40 ,n)) ; mov <n>(%eax),%eax
(define (i386:global->accu o) (define (i386:global->accu o)
(or o global->accu)
`(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax `(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax
(define (i386:value->accu v) (define (i386:value->accu v)
(or v value->accu)
`(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax `(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax
(define (i386:value->accu-ref v)
(or v value->accu-ref)
`(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x<v>,(%eax)
(define (i386:value->accu-ref+n n v)
`(#xc7 #x40 ,n ,@(int->bv32 v))) ; movl $<v>,0x<n>(%eax)
(define (i386:base->accu-ref)
'(#x89 #x10)) ; mov %edx,(%eax)
(define (i386:value->base v) (define (i386:value->base v)
`(#xba ,@(int->bv32 v))) ; mov $<v>,%edx `(#xba ,@(int->bv32 v))) ; mov $<v>,%edx
@ -170,12 +218,24 @@
#x80 #xf4 #x40 ; xor $0x40,%ah #x80 #xf4 #x40 ; xor $0x40,%ah
#x9e)) ; sahf #x9e)) ; sahf
(define (i386:accu-cmp-value v)
`(#x83 #xf8 ,v)) ; cmp $<v>,%eax
(define (i386:accu-test) (define (i386:accu-test)
'(#x85 #xc0)) ; test %eax,%eax '(#x85 #xc0)) ; test %eax,%eax
(define (i386:jump n) (define (i386:Xjump n)
`(#xe9 ,@(int->bv32 n))) ; jmp . + <n>
(define (i386:Xjump-nz n)
`(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n>
(define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c
`(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp <n> `(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp <n>
;; (define (i386:jump n)
;; `(#xeb ,(if (>= n 0) n (- n 2)))) ; jmp <n>
(define (i386:jump-c n) (define (i386:jump-c n)
`(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n> `(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n>

14
module/mes/libc-i386.scm
View file

@ -29,16 +29,24 @@
#:use-module (mes elf) #:use-module (mes elf)
#:export ( #:export (
i386:accu-not i386:accu-not
i386:accu-cmp-value
i386:accu->global i386:accu->global
i386:accu->local i386:accu->local
i386:accu-non-zero? i386:accu-non-zero?
i386:accu-test i386:accu-test
i386:accu-zero? i386:accu-zero?
i386:accu+accu
i386:accu+base
i386:accu-shl
i386:base-sub i386:base-sub
i386:base->accu
i386:base->accu-ref
i386:base-mem->accu i386:base-mem->accu
i386:byte-base-sub i386:byte-base-sub
i386:byte-base-mem->accu i386:byte-base-mem->accu
i386:byte-local->accu
i386:byte-mem->accu i386:byte-mem->accu
i386:base-mem+n->accu
i386:byte-mem->base i386:byte-mem->base
i386:byte-test-base i386:byte-test-base
i386:byte-sub-base i386:byte-sub-base
@ -68,6 +76,7 @@
i386:push-global i386:push-global
i386:push-global-ref i386:push-global-ref
i386:push-local i386:push-local
i386:push-local-de-ref
i386:push-local-ref i386:push-local-ref
i386:ret i386:ret
i386:ret-local i386:ret-local
@ -75,12 +84,17 @@
i386:test-base i386:test-base
i386:test-jump-z i386:test-jump-z
i386:value->accu i386:value->accu
i386:value->accu-ref
i386:value->accu-ref+n
i386:value->global i386:value->global
i386:value->local i386:value->local
i386:value->base i386:value->base
i386:xor-accu i386:xor-accu
i386:xor-zf i386:xor-zf
i386:Xjump
i386:Xjump-nz
;; libc ;; libc
i386:exit i386:exit
i386:open i386:open

62
scaffold/t.c
View file

@ -72,6 +72,15 @@ puts (char const* s)
return 0; return 0;
} }
int
putchar (int c)
{
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
write (1, (char*)&c, 1);
return 0;
}
int int
strcmp (char const* a, char const* b) strcmp (char const* a, char const* b)
{ {
@ -81,6 +90,15 @@ strcmp (char const* a, char const* b)
int test (char *p); int test (char *p);
#endif #endif
// struct scm {
// int type;
// int car;
// int cdr;
// };
char arena[20];
char *g_cells = arena;
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
@ -97,6 +115,32 @@ main (int argc, char *argv[])
return 22; return 22;
} }
int
swits (int c)
{
int x = -1;
switch (c)
{
case 0:
{
x = 0;
c = 34;
break;
}
case 1:
{
x = 1;
break;
}
default:
{
x = 2;
break;
}
}
return x;
}
int int
test (char *p) test (char *p)
{ {
@ -156,12 +200,26 @@ test (char *p)
puts ("t: if (--i)\n"); puts ("t: if (--i)\n");
if (--i) return 1; if (--i) return 1;
puts ("t: (one == 1) ?"); puts ("t: (one == 1) ?\n");
(one == 1) ? 1 : exit (1); (one == 1) ? 1 : exit (1);
puts ("t: (f) ?"); puts ("t: (f) ?\n");
(f) ? exit (1) : 1; (f) ? exit (1) : 1;
puts ("t: *x != 'Q'\n");
g_cells[0] = 'Q';
char *x = g_cells;
if (*x != 'Q') return 1;
puts ("t: switch 0\n");
if (swits (0) != 0) return swits (0);
puts ("t: switch 1\n");
if (swits (1) != 1) return 1;
puts ("t: switch -1\n");
if (swits (-1) != 2) return 1;
puts ("t: if (1)\n"); puts ("t: if (1)\n");
if (1) goto ok0; if (1) goto ok0;
return 1; return 1;