mescc: Refactor compiler.
* module/language/c99/compiler.mes (make, clone): Lightweight functional GOOPS-like list-based info structure. (make-text+globals+locals): Remove. (ast->info): Rename from statement->text+globals+locals, refactor. Update callers. (function->info): Rename from function->globals, refactor. Update callers. (ast-list->info): New function.
This commit is contained in:
Jan Nieuwenhuizen
parent
21a6f2ca52
commit
4a3e419e30
|
|
@ -34,7 +34,8 @@
|
|||
(mes-use-module (mes elf-util))
|
||||
(mes-use-module (mes pmatch))
|
||||
(mes-use-module (mes elf))
|
||||
(mes-use-module (mes libc-i386))))
|
||||
(mes-use-module (mes libc-i386))
|
||||
(mes-use-module (mes optargs))))
|
||||
|
||||
(define (logf port string . rest)
|
||||
(apply format (cons* port string rest))
|
||||
|
|
@ -45,17 +46,19 @@
|
|||
(apply logf (cons* (current-error-port) string rest)))
|
||||
|
||||
(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
|
||||
;;(define (gnuc-xdef? name mode) (equal? name "__GNUC__"))
|
||||
;; (define (gnuc-xdef? name mode)
|
||||
;; (cond ((equal? name "__GNUC__") #t)
|
||||
;; ((equal? name "asm") #f)))
|
||||
|
||||
(define (mescc)
|
||||
(parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
|
||||
#:cpp-defs '(("__GNUC__" . "0") ("__NYACC__" . "1"))
|
||||
#:xdef? gnuc-xdef?
|
||||
#:mode 'code
|
||||
))
|
||||
(parse-c99
|
||||
#:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
|
||||
#:cpp-defs '(
|
||||
("__GNUC__" . "0")
|
||||
("__NYACC__" . "1")
|
||||
("VERSION" . "0.4")
|
||||
("PREFIX" . "")
|
||||
)
|
||||
#:xdef? gnuc-xdef?
|
||||
#:mode 'code
|
||||
))
|
||||
|
||||
(define (write-any x)
|
||||
(write-char (cond ((char? x) x)
|
||||
|
|
@ -80,27 +83,74 @@
|
|||
((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
|
||||
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
|
||||
|
||||
(define (ident-ref locals)
|
||||
(define <info> '<info>)
|
||||
(define <functions> '<functions>)
|
||||
(define <globals> '<globals>)
|
||||
(define <locals> '<locals>)
|
||||
(define <text> '<text>)
|
||||
(define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
|
||||
(pmatch o
|
||||
(<info> (list <info>
|
||||
(cons <functions> functions)
|
||||
(cons <globals> globals)
|
||||
(cons <locals> locals)
|
||||
(cons <text> text)))))
|
||||
|
||||
(define (.functions o)
|
||||
(pmatch o
|
||||
((<info> . ,alist) (assq-ref alist <functions>))))
|
||||
|
||||
(define (.globals o)
|
||||
(pmatch o
|
||||
((<info> . ,alist) (assq-ref alist <globals>))))
|
||||
|
||||
(define (.locals o)
|
||||
(pmatch o
|
||||
((<info> . ,alist) (assq-ref alist <locals>))))
|
||||
|
||||
(define (.text o)
|
||||
(pmatch o
|
||||
((<info> . ,alist) (assq-ref alist <text>))))
|
||||
|
||||
(define (info? o)
|
||||
(and (pair? o) (eq? (car o) <info>)))
|
||||
|
||||
(define (clone o . rest)
|
||||
(cond ((info? o)
|
||||
(let ((functions (.functions o))
|
||||
(globals (.globals o))
|
||||
(locals (.locals o))
|
||||
(text (.text o)))
|
||||
(let-keywords rest
|
||||
#f
|
||||
((functions functions)
|
||||
(globals globals)
|
||||
(locals locals)
|
||||
(text text))
|
||||
(make <info> #:functions functions #:globals globals #:locals locals #:text text))))))
|
||||
|
||||
(define (ref-local locals)
|
||||
(lambda (o)
|
||||
;; (stderr "IDENT REF[~a]: ~a => ~a\n" o (assoc-ref locals o) (i386:ref-local (assoc-ref locals o)))
|
||||
(i386:ref-local (assoc-ref locals o))))
|
||||
|
||||
(define (global-ref globals)
|
||||
(define (ref-global globals)
|
||||
(lambda (o)
|
||||
(lambda (s t d)
|
||||
(i386:ref-global (+ (data-offset o globals) d)))))
|
||||
(lambda (f g t d)
|
||||
(i386:ref-global (+ (data-offset o g;;lobals
|
||||
) d)))))
|
||||
|
||||
(define (expr->arg globals locals) ;; FIXME: get Mes curried-definitions
|
||||
(lambda (o)
|
||||
(pmatch o
|
||||
((p-expr (fixed ,value)) (string->number value))
|
||||
((p-expr (string ,string)) ((global-ref globals) string))
|
||||
((p-expr (ident ,name)) ((ident-ref locals) name))
|
||||
((p-expr (string ,string)) ((ref-global globals) string))
|
||||
((p-expr (ident ,name)) ((ref-local locals) name))
|
||||
|
||||
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
|
||||
(let ((value (string->number value))
|
||||
(size 4)) ;; FIXME: type: int
|
||||
(lambda (s t d)
|
||||
(lambda (f g t d)
|
||||
(append
|
||||
((ident->base locals) name)
|
||||
(i386:value->accu (* size value)) ;; FIXME: type: int
|
||||
|
|
@ -124,265 +174,202 @@
|
|||
(lambda (o)
|
||||
(i386:local->base (assoc-ref locals o))))
|
||||
|
||||
;; (define (global-accu globals)
|
||||
;; (lambda (o)
|
||||
;; (lambda (s t d)
|
||||
;; (i386:accu-global (+ (data-offset o globals) d)))))
|
||||
|
||||
(define (expr->accu globals locals)
|
||||
(define (expr->accu info)
|
||||
(lambda (o)
|
||||
(pmatch o
|
||||
((p-expr (fixed ,value)) (string->number value))
|
||||
((p-expr (ident ,name)) ((ident->accu locals) name))
|
||||
((p-expr (ident ,name)) ((ident->accu (.locals info)) name))
|
||||
(_
|
||||
(format (current-error-port) "SKIP expr-accu=~a\n" o)
|
||||
0)
|
||||
)))
|
||||
|
||||
(define (expr->globals o)
|
||||
(pmatch o
|
||||
((p-expr (string ,string)) (string->globals string))
|
||||
(_ #f)))
|
||||
(define (string->global string)
|
||||
(cons string (append (string->list string) (list #\nul))))
|
||||
|
||||
(define make-text+globals+locals cons*)
|
||||
(define .text car)
|
||||
(define .globals cadr)
|
||||
(define .locals cddr)
|
||||
(define (expr->global o)
|
||||
(pmatch o
|
||||
((p-expr (string ,string)) (string->global string))
|
||||
(_ #f)))
|
||||
|
||||
(define (dec->hex o)
|
||||
(number->string o 16))
|
||||
|
||||
(define (text->list o)
|
||||
(append-map (lambda (f) (f '() 0 0)) o))
|
||||
|
||||
(define (byte->hex o)
|
||||
(string->number (string-drop o 2) 16))
|
||||
|
||||
(define (asm->hex o)
|
||||
(let ((prefix ".byte "))
|
||||
(if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
|
||||
(let ((s (string-drop o (string-length prefix))))
|
||||
(map byte->hex (string-split s #\space))))))
|
||||
(if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
|
||||
(let ((s (string-drop o (string-length prefix))))
|
||||
(map byte->hex (string-split s #\space))))))
|
||||
|
||||
(define (statement->text+globals+locals text+globals+locals)
|
||||
(define (ast->info info)
|
||||
(lambda (o)
|
||||
;;(stderr "S=~a\n" o)
|
||||
(let* ((text (.text text+globals+locals))
|
||||
(globals (.globals text+globals+locals))
|
||||
(locals (.locals text+globals+locals)))
|
||||
;; (stderr " tsl=~a\n" text+globals+locals)
|
||||
;; (stderr " locals=~s\n" locals)
|
||||
(pmatch o
|
||||
(let ((globals (.globals info))
|
||||
(locals (.locals info))
|
||||
(text (.text info)))
|
||||
(define (add-local name)
|
||||
(acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
|
||||
|
||||
;; (stderr "S=~a\n" o)
|
||||
;; (stderr " info=~a\n" info)
|
||||
;; (stderr " globals=~a\n" globals)
|
||||
(pmatch o
|
||||
(((trans-unit . _) . _) ((ast-list->info info) o))
|
||||
((trans-unit . ,elements) ((ast-list->info info) elements))
|
||||
((fctn-defn . _) ((function->info info) o))
|
||||
((comment . _) info)
|
||||
((cpp-stmt (define (name ,name) (repl ,value)))
|
||||
(stderr "SKIP: #define ~a ~a\n" name value)
|
||||
info)
|
||||
|
||||
((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
|
||||
|
||||
((expr-stmt (fctn-call (p-expr (ident ,name))
|
||||
(expr-list (p-expr (string ,string)))))
|
||||
;;(stderr "S1 string=~a\n" string)
|
||||
(if (equal? name "asm")
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list (lambda (s t d) (asm->hex string))))
|
||||
globals
|
||||
locals)
|
||||
|
||||
(make-text+globals+locals
|
||||
(append text
|
||||
(list (lambda (s t d)
|
||||
(i386:call s t d
|
||||
(+ t (function-offset name s))
|
||||
(+ d (data-offset string s))))))
|
||||
(append globals (list (string->globals string)))
|
||||
locals)))
|
||||
(if (equal? name "asm") (clone info #:text (append text (list (lambda (f g t d) (asm->hex string)))))
|
||||
(let ((globals (append globals (list (string->global string)))))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(i386:call f g t d
|
||||
(+ t (function-offset name f))
|
||||
(+ d (data-offset string globals
|
||||
))))))
|
||||
#:globals globals))))
|
||||
|
||||
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
|
||||
;;(stderr "S1 expr-list=~a\n" expr-list)
|
||||
(let* ((globals (append globals (filter-map expr->globals expr-list)))
|
||||
(let* ((globals (append globals (filter-map expr->global expr-list)))
|
||||
(args (map (expr->arg globals locals) expr-list)))
|
||||
(make-text+globals+locals
|
||||
(append text
|
||||
(list (lambda (s t d) (apply i386:call (cons* s t d (+ t (function-offset name s)) args)))))
|
||||
globals
|
||||
locals)))
|
||||
|
||||
((compd-stmt (block-item-list . ,statements))
|
||||
(let loop ((statements statements)
|
||||
(text+globals+locals (make-text+globals+locals text globals locals)))
|
||||
(if (null? statements) text+globals+locals
|
||||
(let* ((statement (car statements))
|
||||
(r ((statement->text+globals+locals text+globals+locals) statement)))
|
||||
(loop (cdr statements) r)))))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(apply i386:call (cons* f g t d
|
||||
(+ t (function-offset name f)) args)))))
|
||||
#:globals globals)))
|
||||
|
||||
((if (gt (p-expr (ident ,name)) (p-expr (fixed ,value))) ,body)
|
||||
(let* ((value (string->number value))
|
||||
|
||||
(t+s+l (make-text+globals+locals '() globals locals))
|
||||
|
||||
(body-t+s+l ((statement->text+globals+locals t+s+l) body))
|
||||
(body-text (.text body-t+s+l))
|
||||
;;(body-globals (.globals body-t+s+l))
|
||||
(globals (.globals body-t+s+l))
|
||||
(body-locals (.locals body-t+s+l))
|
||||
(info (clone info #:text '()))
|
||||
(body-info ((ast->info info) body))
|
||||
(body-text (.text body-info))
|
||||
(body-length (length (text->list body-text))))
|
||||
|
||||
(make-text+globals+locals
|
||||
(append text
|
||||
(list (lambda (s t d)
|
||||
(append
|
||||
(i386:local-test (assoc-ref locals name) value)
|
||||
(i386:jump-le body-length))))
|
||||
body-text)
|
||||
globals
|
||||
locals)))
|
||||
(clone info #:text
|
||||
(append text
|
||||
(list (lambda (f g t d)
|
||||
(append
|
||||
(i386:local-test (assoc-ref locals name) value)
|
||||
(i386:jump-le body-length))))
|
||||
body-text)
|
||||
#:globals (.globals body-info))))
|
||||
|
||||
((while ,test ,body)
|
||||
(let* ((t+s+l (make-text+globals+locals '() globals locals))
|
||||
|
||||
(body-t+s+l ((statement->text+globals+locals t+s+l) body))
|
||||
(body-text (.text body-t+s+l))
|
||||
;;(body-globals (.globals body-t+s+l))
|
||||
(globals (.globals body-t+s+l))
|
||||
(body-locals (.locals body-t+s+l))
|
||||
(let* ((info (clone info #:text '()))
|
||||
(body-info ((ast->info info) body))
|
||||
(body-text (.text body-info))
|
||||
(body-length (length (text->list body-text)))
|
||||
|
||||
(test-t+s+l ((statement->text+globals+locals t+s+l) test))
|
||||
(test-text (.text test-t+s+l))
|
||||
(test-globals (.globals test-t+s+l))
|
||||
(test-locals (.locals test-t+s+l))
|
||||
(test-info ((ast->info info) test))
|
||||
(test-text (.text test-info))
|
||||
(test-length (length (text->list test-text))))
|
||||
|
||||
(make-text+globals+locals
|
||||
(append text
|
||||
(list (lambda (s t d) (i386:jump body-length)))
|
||||
body-text
|
||||
test-text
|
||||
(list (lambda (s t d) (i386:jump-nz (- (+ body-length test-length))))))
|
||||
globals
|
||||
locals)))
|
||||
(clone info #:text
|
||||
(append text
|
||||
(list (lambda (f g t d) (i386:jump body-length)))
|
||||
body-text
|
||||
test-text
|
||||
(list (lambda (f g t d) (i386:jump-nz (- (+ body-length test-length))))))
|
||||
#:globals (.globals body-info))))
|
||||
|
||||
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
|
||||
(let ((value (string->number value)))
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list
|
||||
(lambda (s t d)
|
||||
(append
|
||||
((ident->base locals) name)
|
||||
(i386:value->accu value)
|
||||
(i386:mem-byte->accu))))) ; FIXME: type: char
|
||||
globals
|
||||
locals)))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(append
|
||||
((ident->base locals) name)
|
||||
(i386:value->accu value)
|
||||
(i386:mem-byte->accu)))))))) ; FIXME: type: char
|
||||
|
||||
((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list
|
||||
(lambda (s t d)
|
||||
(append
|
||||
((ident->base locals) name)
|
||||
((ident->accu locals) index)
|
||||
(i386:mem-byte->accu))))) ; FIXME: type: char
|
||||
globals
|
||||
locals))
|
||||
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(append
|
||||
((ident->base locals) name)
|
||||
((ident->accu locals) index)
|
||||
(i386:mem-byte->accu))))))) ; FIXME: type: char
|
||||
|
||||
((expr-stmt (post-inc (p-expr (ident ,name))))
|
||||
(make-text+globals+locals
|
||||
(append text
|
||||
(list (lambda (s t d) (i386:local-add (assoc-ref locals name) 1))))
|
||||
globals
|
||||
locals))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(i386:local-add (assoc-ref locals name) 1))))))
|
||||
|
||||
((return ,expr)
|
||||
(make-text+globals+locals
|
||||
(append text (list (i386:ret ((expr->accu globals locals) expr))))
|
||||
globals
|
||||
locals))
|
||||
(clone info #:text
|
||||
(append text (list (i386:ret ((expr->accu info) expr))))))
|
||||
|
||||
;; int i;
|
||||
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
|
||||
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
|
||||
(make-text+globals+locals text globals locals)))
|
||||
(clone info #:locals (add-local name)))
|
||||
|
||||
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
|
||||
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
|
||||
(value (string->number value)))
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
|
||||
globals
|
||||
locals)))
|
||||
(let ((locals (add-local name)))
|
||||
(let ((value (string->number value)))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(i386:local-assign (assoc-ref locals name) value))))
|
||||
#:locals locals))))
|
||||
|
||||
;; 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 (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list (lambda (s t d)
|
||||
(append
|
||||
((ident->accu locals) local)
|
||||
((accu->ident locals) name)))))
|
||||
globals
|
||||
locals)))
|
||||
|
||||
(let ((locals (add-local name)))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(append
|
||||
((ident->accu locals) local)
|
||||
((accu->ident locals) name)))))
|
||||
#:locals locals)))
|
||||
|
||||
;; SCM i = argc;
|
||||
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
|
||||
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list (lambda (s t d)
|
||||
(append
|
||||
((ident->accu locals) local)
|
||||
((accu->ident locals) name)))))
|
||||
globals
|
||||
locals)))
|
||||
(let ((locals (add-local name)))
|
||||
(clone info #:text
|
||||
(append text (list (lambda (f g t d)
|
||||
(append
|
||||
((ident->accu locals) local)
|
||||
((accu->ident locals) name)))))
|
||||
#:locals locals)))
|
||||
|
||||
;; int i = f ();
|
||||
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
|
||||
(let ((locals (acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals)))
|
||||
(let* ((t+s+l (make-text+globals+locals text globals locals))
|
||||
(t+s+l ((statement->text+globals+locals t+s+l)
|
||||
`(expr-stmt (fctn-call ,@call))))
|
||||
(text (.text t+s+l))
|
||||
(globals (.globals t+s+l))
|
||||
(locals (.locals t+s+l)))
|
||||
(make-text+globals+locals
|
||||
(append
|
||||
text
|
||||
(list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
|
||||
globals
|
||||
locals))))
|
||||
(let* ((locals (add-local name))
|
||||
(info (clone info #:locals locals)))
|
||||
(let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
||||
(clone info
|
||||
#:text
|
||||
(append (.text info)
|
||||
(list (lambda (f g t d)
|
||||
(i386:ret-local (assoc-ref locals name)))))
|
||||
#:locals locals))))
|
||||
|
||||
;; 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))
|
||||
(let ((value (string->number value)))
|
||||
(make-text+globals+locals
|
||||
(append text (list (lambda (s t d) (i386:local-assign (assoc-ref locals name) value))))
|
||||
globals
|
||||
locals)))
|
||||
(clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
|
||||
|
||||
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
|
||||
(let* ((t+s+l ((statement->text+globals+locals text+globals+locals)
|
||||
`(expr-stmt (fctn-call ,@call))))
|
||||
(text (.text t+s+l))
|
||||
(globals (.globals t+s+l))
|
||||
(locals (.locals t+s+l)))
|
||||
(make-text+globals+locals
|
||||
(append text (list (lambda (s t d) (i386:ret-local (assoc-ref locals name)))))
|
||||
globals
|
||||
locals)))
|
||||
(let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
||||
(clone info #:text (append (.text info) (list (lambda (f g t d) (i386:ret-local (assoc-ref locals name))))))))
|
||||
|
||||
(_
|
||||
(format (current-error-port) "SKIP statement=~a\n" o)
|
||||
text+globals+locals)))))
|
||||
info)))))
|
||||
|
||||
(define (globals->exe globals)
|
||||
(define (info->exe info)
|
||||
(display "dumping elf\n" (current-error-port))
|
||||
(map write-any (make-elf globals)))
|
||||
(map write-any (make-elf (.functions info) (.globals info))))
|
||||
|
||||
(define (.formals o)
|
||||
(pmatch o
|
||||
|
|
@ -401,7 +388,7 @@
|
|||
(pmatch o
|
||||
((param-list . ,formals)
|
||||
(let ((n (length formals)))
|
||||
(list (lambda (s t d)
|
||||
(list (lambda (f g t d)
|
||||
(append
|
||||
(i386:function-preamble)
|
||||
(append-map (formal->text n) formals (iota n))
|
||||
|
|
@ -414,14 +401,11 @@
|
|||
((param-list . ,formals)
|
||||
(let ((n (length formals)))
|
||||
;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
|
||||
(map cons (map .name formals) (iota n -2 -1))))
|
||||
(_ (format (current-error-port) "formals->globals: no match: ~a\n" o)
|
||||
(map cons (map .name formals) (iota n -2 -1))))
|
||||
(_ (format (current-error-port) "formals->info: no match: ~a\n" o)
|
||||
barf)))
|
||||
|
||||
(define (string->globals string)
|
||||
(make-data string (append (string->list string) (list #\nul))))
|
||||
|
||||
(define (function->globals globals)
|
||||
(define (function->info info)
|
||||
(lambda (o)
|
||||
;;(stderr "\n")
|
||||
(format (current-error-port) "compiling ~a\n" (.name o))
|
||||
|
|
@ -430,11 +414,17 @@
|
|||
(locals (formals->locals (.formals o))))
|
||||
;;(stderr "locals=~a\n" locals)
|
||||
(let loop ((statements (.statements o))
|
||||
(text+globals+locals (make-text+globals+locals text globals locals)))
|
||||
(if (null? statements) (append (.globals text+globals+locals) (list (make-function (.name o) (.text text+globals+locals))))
|
||||
(info (clone info #:locals locals #:text text)))
|
||||
(if (null? statements) (clone info
|
||||
#:functions (append (.functions info) (list (cons (.name o) (.text info)))))
|
||||
(let* ((statement (car statements)))
|
||||
(loop (cdr statements)
|
||||
((statement->text+globals+locals text+globals+locals) (car statements)))))))))
|
||||
(loop (cdr statements) ((ast->info info) (car statements)))))))))
|
||||
|
||||
(define (ast-list->info info)
|
||||
(lambda (elements)
|
||||
(let loop ((elements elements) (info info))
|
||||
(if (null? elements) info
|
||||
(loop (cdr elements) ((ast->info info) (car elements)))))))
|
||||
|
||||
(define _start
|
||||
(let* ((argc-argv
|
||||
|
|
@ -450,10 +440,8 @@
|
|||
(ast (with-input-from-string
|
||||
|
||||
(string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
|
||||
parse-c99))
|
||||
(functions (filter ast:function? (cdr ast))))
|
||||
;;(pretty-print ast (current-error-port))
|
||||
(list (find (lambda (x) (equal? (.name x) "_start")) functions))))
|
||||
parse-c99)))
|
||||
ast))
|
||||
|
||||
(define strlen
|
||||
(let* ((ast (with-input-from-string
|
||||
|
|
@ -463,13 +451,12 @@ strlen (char const* s)
|
|||
{
|
||||
int i = 0;
|
||||
while (s[i]) i++;
|
||||
return i;
|
||||
return i;
|
||||
}
|
||||
"
|
||||
parse-c99))
|
||||
(functions (filter ast:function? (cdr ast))))
|
||||
;;(pretty-print ast (current-error-port))
|
||||
(list (find (lambda (x) (equal? (.name x) "strlen")) functions))))
|
||||
;;paredit:"
|
||||
parse-c99)))
|
||||
ast))
|
||||
|
||||
(define eputs
|
||||
(let* ((ast (with-input-from-string
|
||||
|
|
@ -484,10 +471,9 @@ eputs (char const* s)
|
|||
return 0;
|
||||
}
|
||||
"
|
||||
parse-c99))
|
||||
(functions (filter ast:function? (cdr ast))))
|
||||
;;(pretty-print ast (current-error-port))
|
||||
(list (find (lambda (x) (equal? (.name x) "eputs")) functions))))
|
||||
;;paredit:"
|
||||
parse-c99)))
|
||||
ast))
|
||||
|
||||
(define fputs
|
||||
(let* ((ast (with-input-from-string
|
||||
|
|
@ -495,15 +481,14 @@ eputs (char const* s)
|
|||
int
|
||||
fputs (char const* s, int fd)
|
||||
{
|
||||
int i = strlen (s);
|
||||
int i = strlen (s);
|
||||
write (fd, s, i);
|
||||
return 0;
|
||||
}
|
||||
"
|
||||
parse-c99))
|
||||
(functions (filter ast:function? (cdr ast))))
|
||||
;;(pretty-print ast (current-error-port))
|
||||
(list (find (lambda (x) (equal? (.name x) "fputs")) functions))))
|
||||
;;paredit:"
|
||||
parse-c99)))
|
||||
ast))
|
||||
|
||||
(define puts
|
||||
(let* ((ast (with-input-from-string
|
||||
|
|
@ -518,18 +503,17 @@ puts (char const* s)
|
|||
return 0;
|
||||
}
|
||||
"
|
||||
parse-c99))
|
||||
(functions (filter ast:function? (cdr ast))))
|
||||
;;(pretty-print ast (current-error-port))
|
||||
(list (find (lambda (x) (equal? (.name x) "puts")) functions))))
|
||||
;;paredit:"
|
||||
parse-c99)))
|
||||
ast))
|
||||
|
||||
(define i386:libc
|
||||
(list
|
||||
(make-function "exit" (list i386:exit))
|
||||
(make-function "write" (list i386:write))))
|
||||
(cons "exit" (list i386:exit))
|
||||
(cons "write" (list i386:write))))
|
||||
|
||||
(define libc
|
||||
(append
|
||||
(list
|
||||
strlen
|
||||
eputs
|
||||
fputs
|
||||
|
|
@ -537,8 +521,8 @@ puts (char const* s)
|
|||
|
||||
(define (compile)
|
||||
(let* ((ast (mescc))
|
||||
(functions (filter ast:function? (cdr ast)))
|
||||
(functions (append libc functions _start)))
|
||||
(let loop ((functions functions) (globals i386:libc))
|
||||
(if (null? functions) (globals->exe globals)
|
||||
(loop (cdr functions) ((function->globals globals) (car functions)))))))
|
||||
(info (make <info> #:functions i386:libc))
|
||||
(info ((ast->info info) libc))
|
||||
(info ((ast->info info) ast))
|
||||
(info ((ast->info info) _start)))
|
||||
(info->exe info)))
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@
|
|||
(define-module (language c99 compiler)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (ice-9 pretty-print)
|
||||
#:use-module (mes elf)
|
||||
#:use-module (mes elf-util)
|
||||
|
|
|
|||
|
|
@ -31,48 +31,31 @@
|
|||
(mes
|
||||
(mes-use-module (srfi srfi-1))))
|
||||
|
||||
(define (make-function key value)
|
||||
(cons key (cons 'function value)))
|
||||
(define (functions->lambdas functions)
|
||||
(append-map cdr functions))
|
||||
|
||||
(define (make-data key value)
|
||||
(cons key (cons 'data value)))
|
||||
(define (text->list o)
|
||||
(append-map (lambda (f) (f '() '() 0 0)) o))
|
||||
|
||||
(define (function-symbol? x)
|
||||
(eq? (car x) 'function))
|
||||
(define (functions->text functions globals t d)
|
||||
(let loop ((lambdas (functions->lambdas functions)) (text '()))
|
||||
(if (null? lambdas) text
|
||||
(loop (cdr lambdas)
|
||||
(append text ((car lambdas) functions globals (- (length text)) d))))))
|
||||
|
||||
(define (function-entry? x)
|
||||
(function-symbol? (cdr x)))
|
||||
|
||||
(define (data-symbol? x)
|
||||
(eq? (car x) 'data))
|
||||
|
||||
(define (data-entry? x)
|
||||
(data-symbol? (cdr x)))
|
||||
|
||||
(define (globals->functions globals)
|
||||
(append-map cdr (filter function-symbol? (map cdr globals))))
|
||||
|
||||
(define (globals->text globals t d)
|
||||
(let loop ((functions (globals->functions globals)) (text '()))
|
||||
(if (null? functions) text
|
||||
(loop (cdr functions)
|
||||
(append text ((car functions) globals (- (length text)) d))))))
|
||||
|
||||
(define (function-offset name globals)
|
||||
(let* ((functions (filter function-entry? globals))
|
||||
(prefix (member name (reverse functions)
|
||||
(define (function-offset name functions)
|
||||
(let* ((prefix (member name (reverse functions)
|
||||
(lambda (a b)
|
||||
(equal? (car b) name)))))
|
||||
(if prefix (length (globals->text (cdr prefix) 0 0))
|
||||
(if prefix (length (functions->text (cdr prefix) '() 0 0))
|
||||
0)))
|
||||
|
||||
(define (globals->data globals)
|
||||
(append-map cdr globals))
|
||||
|
||||
(define (data-offset name globals)
|
||||
(let* ((globals (filter data-entry? globals))
|
||||
(prefix (member name (reverse globals)
|
||||
(let* ((prefix (member name (reverse globals)
|
||||
(lambda (a b)
|
||||
(equal? (car b) name)))))
|
||||
(if prefix (length (globals->data (cdr prefix)))
|
||||
0)))
|
||||
|
||||
(define (globals->data globals)
|
||||
(append-map cdr (filter data-symbol? (map cdr globals))))
|
||||
|
|
|
|||
|
|
@ -24,17 +24,12 @@
|
|||
|
||||
(define-module (mes elf-util)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (make-data
|
||||
make-function
|
||||
data-entry?
|
||||
data-symbol?
|
||||
function-entry?
|
||||
function-symbol?
|
||||
data-offset
|
||||
#:export (data-offset
|
||||
function-offset
|
||||
globals->functions
|
||||
globals->data
|
||||
globals->text))
|
||||
functions->lambdas
|
||||
functions->text
|
||||
text->list
|
||||
globals->data))
|
||||
|
||||
(cond-expand
|
||||
(guile-2)
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
(define elf32-off int->bv32)
|
||||
(define elf32-word int->bv32)
|
||||
|
||||
(define (make-elf globals)
|
||||
(define (make-elf functions globals)
|
||||
(define vaddress #x08048000)
|
||||
|
||||
(define ei-magic `(#x7f ,@(string->list "ELF")))
|
||||
|
|
@ -171,15 +171,15 @@
|
|||
,@(string->list ".strtab") #x00 ; 37
|
||||
))
|
||||
|
||||
(define (str globals)
|
||||
(define (str functions)
|
||||
(cons
|
||||
0
|
||||
(append-map
|
||||
(lambda (s) (append (string->list s) (list 0)))
|
||||
(map car globals))))
|
||||
(map car functions))))
|
||||
|
||||
(define text-length
|
||||
(length (globals->text globals 0 0)))
|
||||
(length (functions->text functions globals 0 0)))
|
||||
|
||||
(define data-offset
|
||||
(+ text-offset text-length))
|
||||
|
|
@ -195,17 +195,17 @@
|
|||
(list st-other)
|
||||
(elf32-half st-shndx)))
|
||||
|
||||
(define (sym globals)
|
||||
(define (sym functions globals)
|
||||
(define (symbol->table-entry o)
|
||||
(let* ((name (car o))
|
||||
(offset (function-offset name globals))
|
||||
(len (length (append-map (lambda (f) (f globals 0 0)) (cddr o))))
|
||||
(str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car globals))))))
|
||||
(offset (function-offset name functions))
|
||||
(len (length (append-map (lambda (f) (f functions globals 0 0)) (cddr o))))
|
||||
(str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car functions))))))
|
||||
(i (1+ (length str))))
|
||||
(symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1)))
|
||||
(append
|
||||
(symbol-table-entry 0 0 0 0 0 0)
|
||||
(append-map symbol->table-entry globals)))
|
||||
(append-map symbol->table-entry functions)))
|
||||
|
||||
(define data-address (+ data-offset vaddress))
|
||||
(define text-address (+ text-offset vaddress))
|
||||
|
|
@ -238,11 +238,10 @@
|
|||
(define SHF-EXEC 4)
|
||||
(define SHF-STRINGS #x20)
|
||||
|
||||
(let* ((text (globals->text globals 0 data-address))
|
||||
(let* ((text (functions->text functions globals 0 data-address))
|
||||
(data (globals->data globals))
|
||||
(entry (+ text-offset (function-offset "_start" globals)))
|
||||
(functions (filter function-entry? globals))
|
||||
(sym (sym functions))
|
||||
(entry (+ text-offset (function-offset "_start" functions)))
|
||||
(sym (sym functions globals))
|
||||
(str (str functions)))
|
||||
|
||||
(define (section-headers)
|
||||
|
|
|
|||
|
|
@ -42,20 +42,21 @@
|
|||
`(#x68 ,@(int->bv32 o))) ; push $0x<o>
|
||||
|
||||
(define (i386:ref-local n)
|
||||
(or n rl)
|
||||
`(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x<n>(%ebp)
|
||||
|
||||
(define (i386:push-accu)
|
||||
`(#x50)) ; push %eax
|
||||
|
||||
(define (i386:push-arg s t d)
|
||||
(define (i386:push-arg f g t d)
|
||||
(lambda (o)
|
||||
(cond ((number? o)
|
||||
`(#x68 ,@(int->bv32 o))) ; push $<o>
|
||||
((pair? o) o)
|
||||
((procedure? o) (o s t d)))))
|
||||
((procedure? o) (o f g t d)))))
|
||||
|
||||
(define (i386:ret . rest)
|
||||
(lambda (s t d)
|
||||
(lambda (f g t d)
|
||||
`(
|
||||
,@(cond ((null? rest) '())
|
||||
((number? (car rest))
|
||||
|
|
@ -63,18 +64,21 @@
|
|||
,@(int->bv32 (car rest))))
|
||||
((pair? (car rest)) (car rest))
|
||||
((procedure? (car rest))
|
||||
((car rest) s t d)))
|
||||
((car rest) f g t d)))
|
||||
#xc9 ; leave
|
||||
#xc3 ; ret
|
||||
)))
|
||||
|
||||
(define (i386:accu->local n)
|
||||
(or n al)
|
||||
`(#x89 #x45 ,(- 0 (* 4 n)))) ; mov ,%eax,-<0xn>(%ebp)
|
||||
|
||||
(define (i386:local->accu n)
|
||||
(or n la)
|
||||
`(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax
|
||||
|
||||
(define (i386:local->base n)
|
||||
(or n lb)
|
||||
`(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx
|
||||
|
||||
(define (i386:mem-byte->accu)
|
||||
|
|
@ -89,22 +93,26 @@
|
|||
`(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax
|
||||
|
||||
(define (i386:local-add n v)
|
||||
(or n ladd)
|
||||
`(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $<v>,0x<n>(%ebp)
|
||||
|
||||
(define (i386:local-assign n v)
|
||||
(or n lassign)
|
||||
`(#xc7 #x45 ,(- 0 (* 4 n)) ; movl $<v>,0x<n>(%ebp)
|
||||
,@(int->bv32 v)))
|
||||
|
||||
(define (i386:local-test n v)
|
||||
(or n lt)
|
||||
`(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp)
|
||||
|
||||
(define (i386:ret-local n)
|
||||
(or n rl)
|
||||
`(
|
||||
#x89 #x45 ,(- 0 (* 4 n)) ; mov %eax,-0x<n>(%ebp)
|
||||
))
|
||||
|
||||
(define (i386:call s t d address . arguments)
|
||||
(let* ((pushes (append-map (i386:push-arg s t d) (reverse arguments)))
|
||||
(define (i386:call f g t d address . arguments)
|
||||
(let* ((pushes (append-map (i386:push-arg f g t d) (reverse arguments)))
|
||||
(s (length pushes))
|
||||
(n (length arguments)))
|
||||
`(
|
||||
|
|
@ -113,7 +121,7 @@
|
|||
#x83 #xc4 ,(* n 4) ; add $00,%esp
|
||||
)))
|
||||
|
||||
(define (i386:exit s t d)
|
||||
(define (i386:exit f g t d)
|
||||
`(
|
||||
#x5b ; pop %ebx
|
||||
#x5b ; pop %ebx
|
||||
|
|
@ -121,7 +129,7 @@
|
|||
#xcd #x80 ; int $0x80
|
||||
))
|
||||
|
||||
;; (define (i386:_start s t d)
|
||||
;; (define (i386:_start f g t d)
|
||||
;; (let* ((prefix
|
||||
;; `(
|
||||
;; #x55 ; push %ebp
|
||||
|
|
@ -141,7 +149,7 @@
|
|||
;; (statement-offset (- (+ (length prefix) (length text-list))))
|
||||
;; (address (+ t (function-offset "main" s))))))
|
||||
|
||||
(define (i386:write s t d)
|
||||
(define (i386:write f g t d)
|
||||
`(
|
||||
#x55 ; push %ebp
|
||||
#x89 #xe5 ; mov %esp,%ebp
|
||||
|
|
|
|||
Loading…
Reference in New Issue