From 11f7f67a4501b7dfa771f85b49ce440de86cdefb Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 17 Jan 2017 19:03:08 +0100 Subject: [PATCH] mescc: Support switch. * module/language/c99/compiler.mes (case->jump-info): New function. (ast->info): Use it. * doc/examples/t.c (swits): Test it. --- guile/mescc.scm | 2 +- module/language/c99/compiler.mes | 484 +++++++++++++++++++++++++++++-- module/mes/elf-util.mes | 13 +- module/mes/libc-i386.mes | 74 ++++- module/mes/libc-i386.scm | 14 + scaffold/t.c | 62 +++- 6 files changed, 613 insertions(+), 36 deletions(-) diff --git a/guile/mescc.scm b/guile/mescc.scm index 25fc9319..3a1b611a 100755 --- a/guile/mescc.scm +++ b/guile/mescc.scm @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -export GUILE_AUTO_COMPILE=0 +export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0} exec ${GUILE-guile} -L $(pwd)/guile -e '(mescc)' -s "$0" "$@" !# diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 13b0f8d1..280c7d9f 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -54,7 +54,7 @@ ("__GNUC__" . "0") ("__NYACC__" . "1") ("VERSION" . "0.4") - ("PREFIX" . "") + ("PREFIX" . "\"\"") ) #:xdef? gnuc-xdef? #:mode 'code @@ -169,6 +169,8 @@ (lambda (f g t d) (i386:push-global (+ (data-offset o g) d))))) +(define push-global-de-ref push-global) + (define (push-ident globals locals) (lambda (o) (let ((local (assoc-ref locals o))) @@ -181,33 +183,68 @@ (if local (i386:push-local-ref local) ((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 (lambda (o) (pmatch o ((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 (ident ,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)) (size 4)) ;; FIXME: type: int - (lambda (f g t d) - (append - ((ident->base (.locals info)) name) - (i386:value->accu (* size value)) ;; FIXME: type: int - (i386:base-mem->accu) ;; FIXME: type: int - (i386:push-accu) ;; hmm - )))) + (append + ((ident->base (.locals info)) name) + (list + (lambda (f g t d) + (append + (i386:value->accu (* size value)) ;; FIXME: type: int + (i386:base-mem->accu) ;; FIXME: type: int + (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))) (lambda (f g t d) ((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 _))) (abs-declr (pointer))) ,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)))) (define (ident->accu info) @@ -215,7 +252,9 @@ (let ((local (assoc-ref (.locals info) o))) (if local (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) (i386:global->accu (+ (data-offset o g) d)))))))) @@ -264,9 +303,108 @@ ((not (fctn-call . _)) ((ast->info info) o)) ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt ((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) - 0) + (format (current-error-port) "SKIP expr->accu=~s\n" o) + 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) @@ -294,10 +432,69 @@ (define (asm->hex o) (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)))) (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 (jump type) (lambda (o) @@ -340,8 +537,20 @@ (_ ((jump i386:jump-z) o))))) (define (cstring->number s) - (if (string-prefix? "0" s) (string->number s 8) - (string->number s))) + (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16)) + ((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) (lambda (o) @@ -438,6 +647,20 @@ else-text) #: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) (let* ((info (clone info #:text '())) @@ -710,7 +933,18 @@ (i386:value->accu b) (i386:sub-base) (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)))) (let ((b (- (cstring->number b)))) (clone info #:text @@ -722,6 +956,17 @@ (i386:sub-base) (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))) (let ((b (cstring->number b)) (info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) @@ -757,6 +1002,46 @@ (i386:byte-test-base) (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))) (let ((b (cstring->number b))) (clone info #:text @@ -815,6 +1100,24 @@ (clone info #:text (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; ((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)) @@ -837,6 +1140,25 @@ (i386:global->accu (+ (data-offset value g) d))))) ((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; ((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)))) @@ -886,6 +1208,24 @@ (append (.text info) ((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 ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields))))) (let ((type (ident->type name "enum")) @@ -893,6 +1233,11 @@ (clone info #:types (append (.types info) (list type)) #: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; ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))) ;;(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))))) (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) info))))) @@ -1012,11 +1452,11 @@ strlen (char const* s) int getchar () { - char c; - int r = read (g_stdin, &c, 1); - //int r = read (0, &c, 1); + char c1; + int r = read (g_stdin, &c1, 1); + //int r = read (0, &c1, 1); if (r < 1) return -1; - return c; + return c1; } " ;;paredit:" @@ -1125,7 +1565,7 @@ strcmp (char const* a, char const* b) (define (compile) (let* ((ast (mescc)) (info (make #:functions i386:libc)) - (info ((ast->info info) libc)) + (ast (append libc ast)) (info ((ast->info info) ast)) (info ((ast->info info) _start))) (info->exe info))) diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes index 4875ecbf..499d56ec 100644 --- a/module/mes/elf-util.mes +++ b/module/mes/elf-util.mes @@ -50,10 +50,15 @@ (define (function-prefix name functions) (member name (reverse functions) (lambda (a b) (equal? (car b) name)))) -(define (function-offset name functions) - (let ((prefix (function-prefix name functions))) - (if prefix (length (functions->text (cdr prefix) '() 0 0)) - 0))) +(define function-offset + (let ((cache '())) + (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))) + (if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset))) + offset))))) (define (label-offset function label functions) (let ((prefix (function-prefix function functions))) diff --git a/module/mes/libc-i386.mes b/module/mes/libc-i386.mes index 7930b737..27c80669 100644 --- a/module/mes/libc-i386.mes +++ b/module/mes/libc-i386.mes @@ -32,9 +32,11 @@ '(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars (define (i386:push-global-ref o) + (or o push-global-ref) `(#x68 ,@(int->bv32 o))) ; push $0x (define (i386:push-global o) + (or o push-global) `(#xa1 ,@(int->bv32 o) ; mov 0x804a000,%eax #x50)) ; push %eax @@ -47,13 +49,23 @@ `(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x(%ebp),%eax #x50)) ; push %eax +(define (i386:push-local-de-ref n) + (or n push-local-de-ref) + `(#x8b #x45 ,(- 0 (* 4 n)) ; mov -0x(%ebp),%eax + #x0f #xb6 #x00 ; movzbl (%eax),%eax + ;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE**** + #x50)) ; push %eax + (define (i386:push-accu) `(#x50)) ; push %eax (define (i386:push-arg f g t d) (lambda (o) + (or o push-arg) (cond ((number? o) `(#x68 ,@(int->bv32 o))) ; push $ + ((and (pair? o) (procedure? (car o))) + (append-map (lambda (p) (p f g t d)) o)) ((pair? o) o) ((procedure? o) (o f g t d)) (_ barf)))) @@ -78,26 +90,46 @@ (define (i386:accu->global n) (or n accu->global) - `(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0 + `(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0 (define (i386:accu-zero?) - `(#x85 #xc0)) ; cmpl %eax,%eax + '(#x85 #xc0)) ; cmpl %eax,%eax (define (i386:accu-non-zero?) (append '(#x85 #xc0) ; cmpl %eax,%eax (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) (or n local->accu) `(#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(%ebp),%eax + (define (i386:local->base n) (or n local->base) `(#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,%edx + (define (i386:global->base n) (or n global->base) - `(#x8b #x15 ,@(int->bv32 n))) ; mov 0xn,%edx + `(#xba ,@(int->bv32 n))) ; mov $,%edx (define (i386:byte-base-mem->accu) '(#x01 #xd0 ; add %edx,%eax @@ -113,12 +145,28 @@ '(#x01 #xd0 ; add %edx,%eax #x8b #x00)) ; mov (%eax),%eax +(define (i386:base-mem+n->accu n) + `(#x01 #xd0 ; add %edx,%eax + #x8b #x40 ,n)) ; mov (%eax),%eax + (define (i386:global->accu o) + (or o global->accu) `(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax (define (i386:value->accu v) + (or v value->accu) `(#xb8 ,@(int->bv32 v))) ; mov $,%eax +(define (i386:value->accu-ref v) + (or v value->accu-ref) + `(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x,(%eax) + +(define (i386:value->accu-ref+n n v) + `(#xc7 #x40 ,n ,@(int->bv32 v))) ; movl $,0x(%eax) + +(define (i386:base->accu-ref) + '(#x89 #x10)) ; mov %edx,(%eax) + (define (i386:value->base v) `(#xba ,@(int->bv32 v))) ; mov $,%edx @@ -132,11 +180,11 @@ (define (i386:local-address->accu n) (or n ladd) - `(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x(%ebp),%eax + `(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x(%ebp),%eax (define (i386:value->global n v) (or n value->global) - `(#xc7 #x05 ,@(int->bv32 n) ; movl $,() + `(#xc7 #x05 ,@(int->bv32 n) ; movl $,() ,@(int->bv32 v))) (define (i386:value->local n v) @@ -157,7 +205,7 @@ #xe8 ,@(int->bv32 (- address 5 s)) ; call relative #x83 #xc4 ,(* n 4) ; add $00,%esp ))) - + (define (i386:accu-not) `(#x0f #x94 #xc0 ; sete %al #x0f #xb6 #xc0)) ; movzbl %al,%eax @@ -170,12 +218,24 @@ #x80 #xf4 #x40 ; xor $0x40,%ah #x9e)) ; sahf +(define (i386:accu-cmp-value v) + `(#x83 #xf8 ,v)) ; cmp $,%eax + (define (i386:accu-test) '(#x85 #xc0)) ; test %eax,%eax -(define (i386:jump n) +(define (i386:Xjump n) + `(#xe9 ,@(int->bv32 n))) ; jmp . + + +(define (i386:Xjump-nz n) + `(#x0f #x85 ,@(int->bv32 n))) ; jnz . + + +(define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c `(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp +;; (define (i386:jump n) +;; `(#xeb ,(if (>= n 0) n (- n 2)))) ; jmp + (define (i386:jump-c n) `(#x72 ,(if (>= n 0) n (- n 2)))) ; jc diff --git a/module/mes/libc-i386.scm b/module/mes/libc-i386.scm index 610d1747..9b057f69 100644 --- a/module/mes/libc-i386.scm +++ b/module/mes/libc-i386.scm @@ -29,16 +29,24 @@ #:use-module (mes elf) #:export ( i386:accu-not + i386:accu-cmp-value i386:accu->global i386:accu->local i386:accu-non-zero? i386:accu-test i386:accu-zero? + i386:accu+accu + i386:accu+base + i386:accu-shl i386:base-sub + i386:base->accu + i386:base->accu-ref i386:base-mem->accu i386:byte-base-sub i386:byte-base-mem->accu + i386:byte-local->accu i386:byte-mem->accu + i386:base-mem+n->accu i386:byte-mem->base i386:byte-test-base i386:byte-sub-base @@ -68,6 +76,7 @@ i386:push-global i386:push-global-ref i386:push-local + i386:push-local-de-ref i386:push-local-ref i386:ret i386:ret-local @@ -75,12 +84,17 @@ i386:test-base i386:test-jump-z i386:value->accu + i386:value->accu-ref + i386:value->accu-ref+n i386:value->global i386:value->local i386:value->base i386:xor-accu i386:xor-zf + i386:Xjump + i386:Xjump-nz + ;; libc i386:exit i386:open diff --git a/scaffold/t.c b/scaffold/t.c index ae1949a4..79590fba 100644 --- a/scaffold/t.c +++ b/scaffold/t.c @@ -72,6 +72,15 @@ puts (char const* s) 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 strcmp (char const* a, char const* b) { @@ -81,6 +90,15 @@ strcmp (char const* a, char const* b) int test (char *p); #endif +// struct scm { +// int type; +// int car; +// int cdr; +// }; + +char arena[20]; +char *g_cells = arena; + int main (int argc, char *argv[]) { @@ -97,6 +115,32 @@ main (int argc, char *argv[]) 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 test (char *p) { @@ -156,12 +200,26 @@ test (char *p) puts ("t: if (--i)\n"); if (--i) return 1; - puts ("t: (one == 1) ?"); + puts ("t: (one == 1) ?\n"); (one == 1) ? 1 : exit (1); - puts ("t: (f) ?"); + puts ("t: (f) ?\n"); (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"); if (1) goto ok0; return 1;