diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 5e677e79..66c9c1da 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -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 ') +(define ') +(define ') +(define ') +(define ') +(define* (make o #:key (functions '()) (globals '()) (locals '()) (text '())) + (pmatch o + ( (list + (cons functions) + (cons globals) + (cons locals) + (cons text))))) + +(define (.functions o) + (pmatch o + (( . ,alist) (assq-ref alist )))) + +(define (.globals o) + (pmatch o + (( . ,alist) (assq-ref alist )))) + +(define (.locals o) + (pmatch o + (( . ,alist) (assq-ref alist )))) + +(define (.text o) + (pmatch o + (( . ,alist) (assq-ref alist )))) + +(define (info? o) + (and (pair? o) (eq? (car o) ))) + +(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 #: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 #:functions i386:libc)) + (info ((ast->info info) libc)) + (info ((ast->info info) ast)) + (info ((ast->info info) _start))) + (info->exe info))) diff --git a/module/language/c99/compiler.scm b/module/language/c99/compiler.scm index fd53c98c..6d57a75e 100644 --- a/module/language/c99/compiler.scm +++ b/module/language/c99/compiler.scm @@ -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) diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes index afe15331..2e8a2379 100644 --- a/module/mes/elf-util.mes +++ b/module/mes/elf-util.mes @@ -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)))) diff --git a/module/mes/elf-util.scm b/module/mes/elf-util.scm index 0bd24417..3066abab 100644 --- a/module/mes/elf-util.scm +++ b/module/mes/elf-util.scm @@ -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) diff --git a/module/mes/elf.mes b/module/mes/elf.mes index 7c39ab1a..5761144f 100644 --- a/module/mes/elf.mes +++ b/module/mes/elf.mes @@ -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) diff --git a/module/mes/libc-i386.mes b/module/mes/libc-i386.mes index 4a3fa51f..0a0d02a1 100644 --- a/module/mes/libc-i386.mes +++ b/module/mes/libc-i386.mes @@ -42,20 +42,21 @@ `(#x68 ,@(int->bv32 o))) ; push $0x (define (i386:ref-local n) + (or n rl) `(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x(%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 $ ((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 $,%eax (define (i386:local-add n v) + (or n ladd) `(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $,0x(%ebp) (define (i386:local-assign n v) + (or n lassign) `(#xc7 #x45 ,(- 0 (* 4 n)) ; movl $,0x(%ebp) ,@(int->bv32 v))) (define (i386:local-test n v) + (or n lt) `(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $,0x(%ebp) (define (i386:ret-local n) + (or n rl) `( #x89 #x45 ,(- 0 (* 4 n)) ; mov %eax,-0x(%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