From 2027754a59086e4a4cbb11d474f33e5924ae499c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 17 May 2017 13:56:25 +0200 Subject: [PATCH] mescc: support -c, -o. * module/language/c99/compiler.mes: Throughout: quote lambda's. (current-eval): New function. Thanks Andy! (object->list): New function. Update callers. (c99-input->info): Dump a.o. (initzer->non-const, function:object->list): New functions. (info:object->list): New function. (c99-input->elf): Call it. * module/mes/as-i386: Throughout: quote lambda's. * scripts/mescc.mes (main): Rewrite. * guile/mescc.scm (main): Likewise. --- guile/mescc.scm | 96 +++++-- make/mescc-guile.make | 2 +- make/mescc-mes.make | 3 +- module/language/c99/compiler.mes | 480 +++++++++++++++++++------------ module/language/c99/compiler.scm | 8 +- module/mes/elf-util.mes | 4 +- module/mes/elf.mes | 2 +- module/mes/libc-i386.mes | 157 +++++----- scripts/mescc.mes | 93 ++++-- 9 files changed, 533 insertions(+), 312 deletions(-) diff --git a/guile/mescc.scm b/guile/mescc.scm index 83afbd9e..ca29bbc3 100755 --- a/guile/mescc.scm +++ b/guile/mescc.scm @@ -2,8 +2,8 @@ # -*-scheme-*- GODIR=${GODIR-@GODIR@} GUILEDIR=${GUILEDIR-@GUILEDIR@} -[ "$GODIR" = @"GODIR"@ ] && GODIR=guile -[ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=guile +[ "$GODIR" = @"GODIR"@ ] && GODIR=$(dirname $0) +[ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=$(dirname $0) export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0} exec ${GUILE-guile} -L $GUILEDIR -C $GODIR -e '(mescc)' -s "$0" "$@" !# @@ -36,8 +36,9 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm (define-module (mescc) #:use-module (language c99 compiler) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 pretty-print) + #:use-module (ice-9 getopt-long) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:export (main)) (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@")) @@ -51,19 +52,76 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm (module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix) (module-define! (resolve-module '(language c99 compiler)) '%version %version) -(define (main arguments) - (let* ((files (cdr arguments)) - (file (if (null? files) (string-append %docdir "examples/main.c") - (car files)))) - (cond ((equal? file "--help") - (format (current-error-port) "Usage: mescc.scm [--help|--version|FILE] > a.out\n") - (exit 0)) - ((equal? file "--version") - (format (current-error-port) "mescc.scm (mes) ~a\n" %version) - (exit 0))) - (format (current-error-port) "input: ~a\n" file) - (with-input-from-file file - c99-input->elf))) +(define (parse-opts args) + (let* ((option-spec + '((c (single-char #\c)) + (D (single-char #\D) (value #t)) + (help (single-char #\h)) + (I (single-char #\I) (value #t)) + (o (single-char #\o) (value #t)) + (version (single-char #\V) (value #t)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (null? files))) + (version? (option-ref options 'version #f))) + (or + (and version? + (format (current-output-port) "mescc.scm (mes) ~a\n" %version)) + (and (or help? usage?) + (format (or (and usage? (current-error-port)) (current-output-port)) "\ +Usage: mescc [OPTION]... FILE... + -c compile and assemble, but do not link + -D DEFINE define DEFINE + -h, --help display this help and exit + -I DIR append DIR to include path + -o FILE write output to FILE + -v, --version display version and exit +") + (exit (or (and usage? 2) 0))) + options))) -(format (current-error-port) "compiler loaded\n") -(format (current-error-port) "calling ~s\n" (cons 'main (command-line))) +(define (object->info file) + (let* ((string (with-input-from-file file read-string)) + (module (resolve-module '(language c99 compiler)))) + (eval-string string module))) + +(define (object->info file) + (let* ((lst (with-input-from-file file read)) + (module (resolve-module '(language c99 compiler)))) + (eval lst module))) + +(define (source->info defines includes) + (lambda (file) + (with-input-from-file file + (lambda () + ((c99-input->info #:defines defines #:includes includes)))))) + +(define (main args) + (let* ((options (parse-opts args)) + (files (option-ref options '() '())) + (file (if (null? files) (string-append %docdir "examples/main.c") + (car files))) + (compile? (option-ref options 'c #f)) + (sources (filter (cut string-suffix? ".c" <>) files)) + (objects (filter (negate (cut string-suffix? ".c" <>)) files)) + (base (substring file (1+ (or (string-rindex file #\/) -1)) (- (string-length file) 2))) + (out (option-ref options 'o (if compile? (string-append base ".o") "a.out"))) + (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o))))) + (defines (reverse (filter-map (multi-opt 'D) options))) + (includes (reverse (filter-map (multi-opt 'I) options)))) + (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options) + (format (current-error-port) "output: ~a\n" out)) + (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files)) + (format (current-error-port) "inputs: ~a\n" files) + (with-output-to-file out + (lambda () + (set-port-encoding! (current-output-port) "ISO-8859-1") + (if (pair? objects) (let ((infos (map object->info objects))) + (if compile? (infos->object infos) + (infos->elf infos))) + (let ((infos (map (source->info defines includes) sources))) + (if compile? (infos->object infos) + (infos->elf infos)))))) + (if (not compile?) + (chmod out #o755)))) diff --git a/make/mescc-guile.make b/make/mescc-guile.make index 485f156a..e0f84ea3 100644 --- a/make/mescc-guile.make +++ b/make/mescc-guile.make @@ -5,6 +5,6 @@ $(OUT)/$(TARGET): $(INSTALL_GO_FILES) $(OUT)/$(TARGET): $(C_FILES) @echo " mescc.scm $(notdir $<) -> $(notdir $@)" @rm -f $@ - $(QUIET) INCLUDES=$(C_INCLUDE_PATH) guile/mescc.scm $< > $@ || rm -f $@ + $(QUIET) guile/mescc.scm $(C_INCLUDE_PATH:%=-I %) -o $@ $< || rm -f $@ @[ -f $@ ] && chmod +x $@ ||: include make/reset.make diff --git a/make/mescc-mes.make b/make/mescc-mes.make index 49d754bb..848217d7 100644 --- a/make/mescc-mes.make +++ b/make/mescc-mes.make @@ -2,6 +2,7 @@ CLEAN+=$(OUT)/$(TARGET) ifneq ($(MES_MAX_ARENA),) $(OUT)/$(TARGET): MES_MAX_ARENA-flag:=MES_MAX_ARENA=$(MES_MAX_ARENA) endif +$(OUT)/$(TARGET): C_INCLUDE_PATH:=$(INCLUDES) $(OUT)/$(TARGET): $(MAKEFILE_LIST) $(OUT)/$(TARGET): module/mes/read-0.mo $(OUT)/$(TARGET): module/mes/read-0-32.mo @@ -10,6 +11,6 @@ $(OUT)/$(TARGET): scripts/mes $(OUT)/$(TARGET): $(C_FILES) @echo " mescc.mes $(notdir $<) -> $(notdir $@)" @rm -f $@ - $(QUIET)MES_DEBUG=$(MES_DEBUG) $(MES_MAX_ARENA-flag) MES_FLAGS=--load scripts/mescc.mes $< > $@ || rm -f $@ + $(QUIET)MES_DEBUG=$(MES_DEBUG) $(MES_MAX_ARENA-flag) MES_FLAGS=--load scripts/mescc.mes $(C_INCLUDE_PATH:%=-I %) -o $@ $< || rm -f $@ @[ -f $@ ] && chmod +x $@ ||: include make/reset.make diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index e461004f..1bd8f1a1 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -54,9 +54,9 @@ (define mes? (pair? (current-module))) -(define (c99-input->ast) +(define* (c99-input->ast #:key (defines '()) (includes '())) (parse-c99 - #:inc-dirs (cons* "." "libc/include" "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:)) + #:inc-dirs (append includes (cons* "." "libc/include" "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:))) #:cpp-defs `( "POSIX=0" "_POSIX_SOURCE=0" @@ -81,6 +81,7 @@ ,(string-append "PREFIX=\"" %prefix "\"") ,(string-append "MODULEDIR=\"" %moduledir "\"") ,(string-append "VERSION=\"" %version "\"") + ,@defines ) #:mode 'code)) @@ -203,8 +204,8 @@ (define (push-global globals) (lambda (o) (list - (lambda (f g ta t d) - (i386:push-global (+ (data-offset o g) d)))))) + `(lambda (f g ta t d) + (i386:push-global (+ (data-offset ,o g) d)))))) (define (push-local locals) (lambda (o) @@ -213,8 +214,8 @@ (define (push-global-address globals) (lambda (o) (list - (lambda (f g ta t d) - (i386:push-global-address (+ (data-offset o g) d)))))) + `(lambda (f g ta t d) + (i386:push-global-address (+ (data-offset ,o g) d)))))) (define (push-local-address locals) (lambda (o) @@ -362,18 +363,18 @@ (size (if (= ptr 1) (type->size info type) 4))) (case ptr - ((-1) (list (lambda (f g ta t d) - (i386:global->accu (+ (data-offset o g) d))))) - ((1) (list (lambda (f g ta t d) - (i386:global-address->accu (+ (data-offset o g) d))))) + ((-1) (list `(lambda (f g ta t d) + (i386:global->accu (+ (data-offset ,o g) d))))) + ((1) (list `(lambda (f g ta t d) + (i386:global-address->accu (+ (data-offset ,o g) d))))) - ((2) (list (lambda (f g ta t d) - (append (i386:value->accu (+ (data-offset o g) d)))))) - (else (list (lambda (f g ta t d) - (i386:global-address->accu (+ (data-offset o g) d))))))) + ((2) (list `(lambda (f g ta t d) + (append (i386:value->accu (+ (data-offset ,o g) d)))))) + (else (list `(lambda (f g ta t d) + (i386:global-address->accu (+ (data-offset ,o g) d))))))) (if constant (wrap-as (i386:value->accu constant)) - (list (lambda (f g ta t d) - (i386:global->accu (+ ta (function-offset o f))))))))))) + (list `(lambda (f g ta t d) + (i386:global->accu (+ ta (function-offset ,o f))))))))))) (define (ident-address->accu info) (lambda (o) @@ -391,12 +392,12 @@ (let ((ptr (ident->pointer info o))) (case ptr ;; ((1) - ;; (list (lambda (f g ta t d) - ;; (i386:global->accu (+ (data-offset o g) d))))) - (else (list (lambda (f g ta t d) - (append (i386:value->accu (+ (data-offset o g) d)))))))) - (list (lambda (f g ta t d) - (i386:global->accu (+ ta (function-offset o f)))))))))) + ;; (list `(lambda (f g ta t d) + ;; (i386:global->accu (+ (data-offset ,o g) d))))) + (else (list `(lambda (f g ta t d) + (append (i386:value->accu (+ (data-offset ,o g) d)))))))) + (list `(lambda (f g ta t d) + (i386:global->accu (+ ta (function-offset ,o f)))))))))) (define (ident-address->base info) (lambda (o) @@ -413,10 +414,10 @@ (let ((ptr (ident->pointer info o))) (case ptr ((1) - (list (lambda (f g ta t d) - (i386:global->base (+ (data-offset o g) d))))) - (else (list (lambda (f g ta t d) - (append (i386:value->base (+ (data-offset o g) d)))))))) + (list `(lambda (f g ta t d) + (i386:global->base (+ (data-offset ,o g) d))))) + (else (list `(lambda (f g ta t d) + (append (i386:value->base (+ (data-offset ,o g) d)))))))) (error "TODO ident-address->base" o)))))) (define (value->accu v) @@ -430,15 +431,15 @@ (case ptr (else (wrap-as (i386:accu->local (local:id local)))))) (let ((ptr (ident->pointer info o))) - (list (lambda (f g ta t d) - (i386:accu->global (+ (data-offset o g) d))))))))) + (list `(lambda (f g ta t d) + (i386:accu->global (+ (data-offset ,o g) d))))))))) (define (base->ident info) (lambda (o) (let ((local (assoc-ref (.locals info) o))) (if local (wrap-as (i386:base->local (local:id local))) - (list (lambda (f g ta t d) - (i386:base->global (+ (data-offset o g) d)))))))) + (list `(lambda (f g ta t d) + (i386:base->global (+ (data-offset ,o g) d)))))))) (define (base->ident-address info) (lambda (o) @@ -457,15 +458,15 @@ (lambda (o value) (let ((local (assoc-ref (.locals info) o))) (if local (wrap-as (i386:value->local (local:id local) value)) - (list (lambda (f g ta t d) - (i386:value->global (+ (data-offset o g) d) value))))))) + (list `(lambda (f g ta t d) + (i386:value->global (+ (data-offset ,o g) d) value))))))) (define (ident-add info) (lambda (o n) (let ((local (assoc-ref (.locals info) o))) (if local (wrap-as (i386:local-add (local:id local) n)) - (list (lambda (f g ta t d) - (i386:global-add (+ (data-offset o g) d) n))))))) + (list `(lambda (f g ta t d) + (i386:global-add (+ (data-offset ,o g) d) ,n))))))) (define (ident-address-add info) (lambda (o n) @@ -474,10 +475,10 @@ (i386:local->accu (local:id local)) (i386:accu-mem-add n) (i386:pop-accu))) - (list (lambda (f g ta t d) + (list `(lambda (f g ta t d) (append (i386:push-accu) - (i386:global->accu (+ (data-offset o g) d)) - (i386:accu-mem-add n) + (i386:global->accu (+ (data-offset ,o g) d)) + (i386:accu-mem-add ,n) (i386:pop-accu)))))))) ;; FIXME: see ident->accu @@ -499,16 +500,16 @@ (if global (let ((ptr (ident->pointer info o))) (case ptr - ((-1) (list (lambda (f g ta t d) - (i386:global->base (+ (data-offset o g) d))))) - ((2) (list (lambda (f g ta t d) - (i386:global->base (+ (data-offset o g) d))))) - (else (list (lambda (f g ta t d) - (i386:global-address->base (+ (data-offset o g) d))))))) + ((-1) (list `(lambda (f g ta t d) + (i386:global->base (+ (data-offset ,o g) d))))) + ((2) (list `(lambda (f g ta t d) + (i386:global->base (+ (data-offset ,o g) d))))) + (else (list `(lambda (f g ta t d) + (i386:global-address->base (+ (data-offset ,o g) d))))))) (let ((constant (assoc-ref (.constants info) o))) (if constant (wrap-as (i386:value->base constant)) - (list (lambda (f g ta t d) - (i386:global->base (+ ta (function-offset o f))))))))))))) + (list `(lambda (f g ta t d) + (i386:global->base (+ ta (function-offset ,o f))))))))))))) (define (expr->accu info) (lambda (o) @@ -526,12 +527,12 @@ ((p-expr (string ,string)) (let* ((globals (append globals (list (string->global string)))) (info (clone info #:globals globals))) - (append-text info (list (lambda (f g ta t d) - (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))) + (append-text info (list `(lambda (f g ta t d) + (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d))))))) ((p-expr (string . ,strings)) - (append-text info (list (lambda (f g ta t d) - (i386:global->accu (+ (data-offset (add-s:-prefix (apply string-append strings)) globals) d)))))) + (append-text info (list `(lambda (f g ta t d) + (i386:global->accu (+ (data-offset ,(add-s:-prefix (apply string-append strings)) g) d)))))) ((p-expr (fixed ,value)) (append-text info (value->accu (cstring->number value)))) @@ -663,14 +664,14 @@ (loop (cdr expressions) ((expr->arg info) (car expressions)))))) (n (length expr-list))) (if (and (not (assoc-ref locals name)) - (assoc-ref (.functions info) name)) - (append-text args-info (list (lambda (f g ta t d) - (i386:call f g ta t d (+ t (function-offset name f)) n)))) + (assoc name (.functions info))) + (append-text args-info (list `(lambda (f g ta t d) + (i386:call f g ta t d (+ t (function-offset ,name f)) ,n)))) (let* ((empty (clone info #:text '())) (accu ((expr->accu empty) `(p-expr (ident ,name))))) (append-text args-info (append (.text accu) - (list (lambda (f g ta t d) - (i386:call-accu f g ta t d n)))))))))) + (list `(lambda (f g ta t d) + (i386:call-accu f g ta t d ,n)))))))))) ((fctn-call ,function (expr-list . ,expr-list)) (let* ((text-length (length text)) @@ -681,8 +682,8 @@ (empty (clone info #:text '())) (accu ((expr->accu empty) function))) (append-text args-info (append (.text accu) - (list (lambda (f g ta t d) - (i386:call-accu f g ta t d n))))))) + (list `(lambda (f g ta t d) + (i386:call-accu f g ta t d ,n))))))) ((cond-expr . ,cond-expr) ((ast->info info) `(expr-stmt ,o))) @@ -859,7 +860,7 @@ (clone info #:text (append (.text info) text))) (define (wrap-as o) - (list (lambda (f g ta t d) o))) + (list `(lambda (f g ta t d) ,(cons 'list o)))) (define (expr->accu* info) (lambda (o) @@ -966,9 +967,9 @@ (_ (error "case test: unsupported: " test))))) (lambda (n) (append (wrap-as (i386:accu-cmp-value value)) - (jump-z (+ (length (text->list (jump 0))) + (jump-z (+ (length (object->list (jump 0))) (if (= n 0) 0 - (* n (length (text->list ((test->text 0) 0))))))))))) + (* n (length (object->list ((test->text 0) 0))))))))))) (define (cases+jump cases clause-length) (append-text info (append @@ -992,7 +993,7 @@ (() (let* ((cases-length (length (.text (cases+jump cases 0)))) (clause-text (list-tail (.text clause) cases-length)) - (clause-length (length (text->list clause-text)))) + (clause-length (length (object->list clause-text)))) (clone clause #:text (append (.text (cases+jump cases clause-length)) clause-text)))) @@ -1038,11 +1039,11 @@ (a-jump ((test->jump->info info) a)) (a-text (.text (a-jump 0))) - (a-length (length (text->list a-text))) + (a-length (length (object->list a-text))) (b-jump ((test->jump->info info) b)) (b-text (.text (b-jump 0))) - (b-length (length (text->list b-text)))) + (b-length (length (object->list b-text)))) (lambda (body-length) (let* ((info (append-text info text)) @@ -1062,14 +1063,14 @@ (a-jump ((test->jump->info info) a)) (a-text (.text (a-jump 0))) - (a-length (length (text->list a-text))) + (a-length (length (object->list a-text))) (jump-text (wrap-as (i386:Xjump 0))) - (jump-length (length (text->list jump-text))) + (jump-length (length (object->list jump-text))) (b-jump ((test->jump->info info) b)) (b-text (.text (b-jump 0))) - (b-length (length (text->list b-text))) + (b-length (length (object->list b-text))) (jump-text (wrap-as (i386:Xjump b-length)))) @@ -1225,7 +1226,8 @@ (define (ast->info info) (lambda (o) - (let ((globals (.globals info)) + (let ((functions (.functions info)) + (globals (.globals info)) (locals (.locals info)) (constants (.constants info)) (text (.text info))) @@ -1234,6 +1236,9 @@ (1+ (local:id (cdar locals))))) (locals (cons (make-local name type pointer id) locals))) locals)) + (define (declare name) + (if (member name functions) info + (clone info #:functions (cons (cons name #f) functions)))) (pmatch o (((trans-unit . _) . _) ((ast-list->info info) o)) @@ -1248,7 +1253,7 @@ info) ((break) - (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (text->list text))))))) + (append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text))))))) ;; FIXME: expr-stmt wrapper? (trans-unit info) @@ -1266,7 +1271,7 @@ (body-info ((ast->info test+jump-info) body)) (text-body-info (.text body-info)) (body-text (list-tail text-body-info test-length)) - (body-length (length (text->list body-text))) + (body-length (length (object->list body-text))) (text+test-text (.text (test-jump->info body-length))) (test-text (list-tail text+test-text text-length))) @@ -1288,14 +1293,14 @@ (text-then-info (.text then-info)) (then-text (list-tail text-then-info test-length)) (then-jump-text (wrap-as (i386:Xjump 0))) - (then-jump-length (length (text->list then-jump-text))) - (then-length (+ (length (text->list then-text)) then-jump-length)) + (then-jump-length (length (object->list then-jump-text))) + (then-length (+ (length (object->list then-text)) then-jump-length)) (then+jump-info (clone then-info #:text (append text-then-info then-jump-text))) (else-info ((ast->info then+jump-info) else)) (text-else-info (.text else-info)) (else-text (list-tail text-else-info (length (.text then+jump-info)))) - (else-length (length (text->list else-text))) + (else-length (length (object->list else-text))) (text+test-text (.text (test-jump->info then-length))) (test-text (list-tail text+test-text text-length)) @@ -1321,10 +1326,10 @@ (then-info ((ast->info test+jump-info) then)) (text-then-info (.text then-info)) (then-text (list-tail text-then-info test-length)) - (then-length (length (text->list then-text))) + (then-length (length (object->list then-text))) (jump-text (wrap-as (i386:Xjump 0))) - (jump-length (length (text->list jump-text))) + (jump-length (length (object->list jump-text))) (test+then+jump-info (clone then-info @@ -1333,7 +1338,7 @@ (else-info ((ast->info test+then+jump-info) else)) (text-else-info (.text else-info)) (else-text (list-tail text-else-info (length (.text test+then+jump-info)))) - (else-length (length (text->list else-text))) + (else-length (length (object->list else-text))) (text+test-text (.text (test-jump->info (+ then-length jump-length)))) (test-text (list-tail text+test-text text-length)) @@ -1352,7 +1357,7 @@ (expr ((expr->accu info) expr)) (empty (clone info #:text '())) (clause-infos (map (clause->jump-info empty) clauses)) - (clause-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) clause-infos)) + (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos)) (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths)) (if (null? clauses) info (let ((c-j ((clause->jump-info info) (car clauses)))) @@ -1370,20 +1375,20 @@ (body-info ((ast->info info) body)) (body-text (.text body-info)) - (body-length (length (text->list body-text))) + (body-length (length (object->list body-text))) (step-info ((expr->accu info) step)) (step-text (.text step-info)) - (step-length (length (text->list step-text))) + (step-length (length (object->list step-text))) (test-jump->info ((test->jump->info info) test)) (test+jump-info (test-jump->info 0)) - (test-length (length (text->list (.text test+jump-info)))) + (test-length (length (object->list (.text test+jump-info)))) (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length)))) (jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length))))) - (jump-length (length (text->list jump-text))) + (jump-length (length (object->list jump-text))) (test-text (.text (test-jump->info jump-length)))) @@ -1402,7 +1407,7 @@ (let* ((skip-info (lambda (body-length test-length) (clone info #:text (append text (wrap-as (i386:Xjump body-length))) - #:break (cons (+ (length (text->list text)) body-length test-length + #:break (cons (+ (length (object->list text)) body-length test-length (length (i386:Xjump 0))) (.break info))))) (text (.text (skip-info 0 0))) @@ -1411,19 +1416,19 @@ ((ast->info (skip-info body-length test-length)) body))) (body-text (list-tail (.text (body-info 0 0)) text-length)) - (body-length (length (text->list body-text))) + (body-length (length (object->list body-text))) (empty (clone info #:text '())) (test-jump->info ((test->jump->info empty) test)) (test+jump-info (test-jump->info 0)) - (test-length (length (text->list (.text test+jump-info)))) + (test-length (length (object->list (.text test+jump-info)))) (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length))))) - (jump-length (length (text->list jump-text))) + (jump-length (length (object->list jump-text))) (test-text (.text (test-jump->info jump-length))) - (body-info (body-info body-length (length (text->list test-text))))) + (body-info (body-info body-length (length (object->list test-text))))) (clone info #:text (append @@ -1437,15 +1442,15 @@ (body-info ((ast->info info) body)) (body-text (list-tail (.text body-info) text-length)) - (body-length (length (text->list body-text))) + (body-length (length (object->list body-text))) (empty (clone info #:text '())) (test-jump->info ((test->jump->info empty) test)) (test+jump-info (test-jump->info 0)) - (test-length (length (text->list (.text test+jump-info)))) + (test-length (length (object->list (.text test+jump-info)))) (jump-text (wrap-as (i386:Xjump (- (+ body-length test-length))))) - (jump-length (length (text->list jump-text))) + (jump-length (length (object->list jump-text))) (test-text (.text (test-jump->info jump-length)))) (clone info #:text @@ -1461,10 +1466,10 @@ ((goto (ident ,label)) (let* ((jump (lambda (n) (i386:XXjump n))) - (offset (+ (length (jump 0)) (length (text->list text))))) + (offset (+ (length (jump 0)) (length (object->list text))))) (append-text info (append - (list (lambda (f g ta t d) - (jump (- (label-offset (.function info) label f) offset)))))))) + (list `(lambda (f g ta t d) + (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset)))))))) ((return ,expr) (let ((info ((expr->accu info) expr))) @@ -1526,25 +1531,26 @@ (globals (append globals (list (string->global string)))) (info (clone info #:locals locals #:globals globals))) (append-text info (append - (list (lambda (f g ta t d) + (list `(lambda (f g ta t d) (append - (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d))))) + (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d))))) ((accu->ident info) name)))) (let* ((global (string->global string)) (globals (append globals (list global))) (size 4) (global (make-global name type 1 (string->list (make-string size #\nul)))) (globals (append globals (list global))) - (info (clone info #:globals globals)) - (here (data-offset name globals))) + (info (clone info #:globals globals))) (clone info #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data here) - (initzer->data info functions globals ta t d `(initzer (p-expr (string ,string)))) - (list-tail data (+ here size)))))))))) + (list + `(lambda (f g ta t d data) + (let (((here (data-offset ,name g)))) + (append + (list-head data here) + (initzer->data f g ta t d '(initzer (p-expr (string ,string)))) + (list-tail data (+ here ,size))))))))))) ;; char const *p; ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))))) @@ -1597,18 +1603,17 @@ ((ident->accu info) b) ((accu->ident info) name)))) (let* ((globals (append globals (list (ident->global name type 2 0)))) - (here (data-offset name globals))) + (value (assoc-ref constants b))) (clone info #:globals globals #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data here) - ;;(initzer->data info functions globals ta t d initzer) - (initzer->data info functions globals ta t d `(p-expr (ident ,b))) - (list-tail data (+ here 4)))))))) - ;;;(clone info #:globals (append globals (list (ident->global name type 1 0)))) - )) + (list + `(lambda (f g ta t d data) + (let ((here (data-offset ,name g))) + (append + (list-head data here) + (initzer->data f g ta t d '(p-expr (fixed ,value))) + (list-tail data (+ here 4))))))))))) ;; struct foo bar[2]; ;; char arena[20000]; @@ -1715,7 +1720,7 @@ (append text (.text accu) ((accu->ident info) name) - (list (lambda (f g ta t d) + (list `(lambda (f g ta t d) (append (i386:value->base ta) (i386:accu+base))))) #:locals locals))) @@ -1727,21 +1732,22 @@ (info (clone info #:locals locals))) (append-text info (append ((ident->accu info) value) ((accu->ident info) name)))) - (let* ((globals (append globals (list (ident->global name type 1 0)))) - (here (data-offset name globals)) - (there (data-offset value globals))) + (let* ((globals (append globals (list (ident->global name type 1 0))))) (clone info #:globals globals #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data here) - ;;; FIXME: type - ;;; char *x = arena; - (int->bv32 (+ d (data-offset value globals))) - ;;; char *y = x; - ;;;(list-head (list-tail data there) 4) - (list-tail data (+ here 4)))))))))) + (list + `(lambda (f g ta t d data) + (let ((here (data-offset ,name g)) + (there (data-offset ,value g))) + (append + (list-head data here) + ;; FIXME: type + ;; char *x = arena; + (int->bv32 (+ d (data-offset ,value g))) + ;; char *y = x; + ;;(list-head (list-tail data there) 4) + (list-tail data (+ here 4))))))))))) ;; char *p = g_cells; ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value)))))) @@ -1751,18 +1757,18 @@ (info (clone info #:locals locals))) (append-text info (append ((ident->accu info) value) ((accu->ident info) name)))) - (let* ((globals (append globals (list (ident->global name type 1 0)))) - (here (data-offset name globals))) + (let* ((globals (append globals (list (ident->global name type 1 0))))) (clone info #:globals globals #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data here) - ;;; FIXME: type - ;;; char *x = arena;p - (int->bv32 (+ d (data-offset value globals))) - (list-tail data (+ here 4))))))))))) + (list `(lambda (f g ta t d data) + (let ((here (data-offset ,name g))) + (append + (list-head data here) + ;; FIXME: type + ;; char *x = arena;p + (int->bv32 (+ d (data-offset ,value g))) + (list-tail data (+ here 4)))))))))))) ;; enum ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields))))) @@ -1857,24 +1863,26 @@ (let* ((type (decl->type type)) (entries (map initzer->global initzers)) (entry-size 4) - (size (* (length entries) entry-size))) + (size (* (length entries) entry-size)) + (initzers (map (initzer->non-const info) initzers))) (if (.function info) (error "TODO: x[] = {};" o) (let* ((global (make-global name type 2 (string->list (make-string size #\nul)))) (globals (append globals entries (list global))) - (info (clone info #:globals globals)) - (here (data-offset name globals))) + (info (clone info #:globals globals))) (clone info #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data here) - (append-map - (lambda (i) - (initzer->data info functions globals ta t d i)) - initzers) - (list-tail data (+ here size))))))))))) + (list + `(lambda (f g ta t d data) + (let ((here (data-offset ,name g))) + (append + (list-head data here) + (append-map + (lambda (i) + (initzer->data f g ta t d i)) + ',initzers) + (list-tail data (+ here ,size)))))))))))) ;; ;; struct f = {...}; @@ -1882,7 +1890,8 @@ (let* ((type (decl->type type)) (fields (type->description info type)) (size (type->size info type)) - (field-size 4)) ;; FIXME:4, not fixed + (field-size 4) ;; FIXME:4, not fixed + (initzers (map (initzer->non-const info) initzers))) (if (.function info) (let* ((globals (append globals (filter-map initzer->global initzers))) (locals (let loop ((fields (cdr fields)) (locals locals)) @@ -1906,7 +1915,6 @@ (let* ((globals (append globals (filter-map initzer->global initzers))) (global (make-global name type -1 (string->list (make-string size #\nul)))) (globals (append globals (list global))) - (here (data-offset name globals)) (info (clone info #:globals globals)) (field-size 4)) (let loop ((fields (iota (length fields))) (initzers initzers) (info info)) @@ -1917,39 +1925,43 @@ (clone info #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data (+ here offset)) - (initzer->data info functions globals ta t d (car initzers)) - (list-tail data (+ here offset field-size))))))))))))))) + (list + `(lambda (f g ta t d data) + (let ((here (data-offset ,name g))) + (append + (list-head data (+ here ,offset)) + (initzer->data f g ta t d ',(car initzers)) + (list-tail data (+ here ,offset ,field-size)))))))))))))))) ;;char cc = g_cells[c].cdr; ==> generic? ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer)))) - (let ((type (decl->type type))) + (let ((type (decl->type type)) + (initzer ((initzer->non-const info) initzer))) (if (.function info) (let* ((locals (add-local locals name type 0)) (info (clone info #:locals locals))) (clone info #:text (append (.text ((expr->accu info) initzer)) ((accu->ident info) name)))) - (let* ((globals (append globals (list (ident->global name type 1 0)))) - (here (data-offset name globals))) + (let* ((globals (append globals (list (ident->global name type 1 0))))) (clone info #:globals globals #:init (append (.init info) - (list (lambda (functions globals ta t d data) - (append - (list-head data here) - (initzer->data info functions globals ta t d initzer) - (list-tail data (+ here 4))))))))))) + (list + `(lambda (f g ta t d data) + (let ((here (data-offset ,name g))) + (append + (list-head data here) + (initzer->data f g ta t d ',initzer) + (list-tail data (+ here 4)))))))))))) ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - info) + (declare name)) ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment)) - info) + (declare name)) ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)))) (let ((types (.types info))) @@ -1957,23 +1969,23 @@ ;; int foo (); ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - info) + (declare name)) ;; void foo (); ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - info) + (declare name)) ;; void foo (*); ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list)))))) - info) + (declare name)) ;; char const* itoa (); ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list)))))) - info) + (declare name)) ;; char *strcpy (); ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list)))))) - info) + (declare name)) ;; printf (char const* format, ...) ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis)))))) @@ -2017,17 +2029,22 @@ (_ (let ((info ((expr->accu info) o))) (append-text info (wrap-as (i386:accu-zero?))))))))) -(define (initzer->data info functions globals ta t d o) +(define (initzer->non-const info) + (lambda (o) + (pmatch o + ((initzer (p-expr (ident ,name))) + (let ((value (assoc-ref (.constants info) name))) + `(initzer (p-expr (fixed ,(number->string value)))))) + (_ o)))) + +(define (initzer->data f g ta t d o) (pmatch o ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value))) ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value)))) ((initzer (ref-to (p-expr (ident ,name)))) - (int->bv32 (+ ta (function-offset name functions)))) - ((initzer (p-expr (ident ,name))) - (let ((value (assoc-ref (.constants info) name))) - (int->bv32 value))) + (int->bv32 (+ ta (function-offset name f)))) ((initzer (p-expr (string ,string))) - (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d))) + (int->bv32 (+ (data-offset (add-s:-prefix string) g) d))) (_ (error "initzer->data: unsupported: " o)))) (define (.formals o) @@ -2080,7 +2097,7 @@ (define (assert-return text) (let ((return (wrap-as (i386:ret)))) (if (equal? (list-tail text (- (length text) (length return))) return) text - (append text (wrap-as (i386:ret)))))) + (append text return)))) (let* ((name (.name o)) (formals (.formals o)) (text (formals->text formals)) @@ -2088,9 +2105,9 @@ (format (current-error-port) "compiling: ~a\n" name) (let loop ((statements (.statements o)) (info (clone info #:locals locals #:function (.name o) #:text text))) - (if (null? statements) (assert-return (clone info - #:function #f - #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))) + (if (null? statements) (clone info + #:function #f + #:functions (append (.functions info) (list (cons name (assert-return (.text info)))))) (let* ((statement (car statements))) (loop (cdr statements) ((ast->info info) (car statements))))))))) @@ -2101,20 +2118,63 @@ (if (null? elements) info (loop (cdr elements) ((ast->info info) (car elements))))))) -(define (c99-input->info) - (let* ((info (make - #:functions i386:libc - #:types i386:type-alist)) - (foo (stderr "compiling: mlibc\n")) - (info (let loop ((info info) (libc libc)) - (if (null? libc) info - (loop ((ast->info info) ((car libc))) (cdr libc))))) - (foo (stderr "parsing: input\n")) - (ast (c99-input->ast)) - (foo (stderr "compiling: input\n")) - (info ((ast->info info) ast)) - (info ((ast->info info) (_start)))) - info)) +(define current-eval + (let ((module (current-module))) + (lambda (e) (eval e module)))) + +(define (object->list object) + (text->list (map current-eval object))) + +(define (dec->xhex o) + (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100))))) + +(define (write-lambda o) + (newline) + (display " ") + (if (or (not (pair? o)) + (not (eq? (caaddr o) 'list))) (write o) + (list (car o) (cadr o) + (display (string-append "(lambda (f g ta t d) (list " + (string-join (map dec->xhex (cdaddr o)) " ") + "))"))))) + +(define (write-function o) + (stderr "function: ~s\n" (car o)) + (newline) + (display " (") + (write (car o)) (display " ") + (if (not (cdr o)) (display ". #f") + (for-each write-lambda (cdr o))) + (display ")")) + +(define (write-info o) + (stderr "object:\n") + (display "(make \n") + (display " #:types\n '") (pretty-print (.types o) #:width 80) + (display " #:constants\n '") (pretty-print (.constants o) #:width 80) + (display " #:functions '(") (for-each write-function (.functions o)) (display ")") (newline) + (stderr "globals:\n") + (display " #:globals\n '") (pretty-print (.globals o) #:width 80) + (stderr "init:\n") + (display " #:init\n '") (pretty-print (.init o) #:width 80) + (display ")\n")) + +(define* (c99-input->info #:key (defines '()) (includes '())) + (lambda () + (let* ((info (make + #:functions i386:libc + #:types i386:type-alist)) + (foo (stderr "compiling: mlibc\n")) + (info (let loop ((info info) (libc libc)) + (if (null? libc) info + (loop ((ast->info info) ((car libc))) (cdr libc))))) + (foo (stderr "parsing: input\n")) + (ast (c99-input->ast #:defines defines #:includes includes)) + (foo (stderr "compiling: input\n")) + (info ((ast->info info) ast)) + (info ((ast->info info) (_start))) + (info (clone info #:text '() #:locals '()))) + info))) (define (write-any x) (write-char (cond ((char? x) x) @@ -2129,7 +2189,47 @@ (define (info->elf info) (display "dumping elf\n" (current-error-port)) - (for-each write-any (make-elf (.functions info) (.globals info) (.init info)))) + (for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info)))) -(define (c99-input->elf) - ((compose info->elf c99-input->info))) +(define (function:object->text o) + (cons (car o) (and (cdr o) (map current-eval (cdr o))))) + +(define (init:object->text o) + (current-eval o)) + +(define (info:object->text o) + (clone o + #:functions (map function:object->text (.functions o)) + #:init (map init:object->text (.init o)))) + +(define* (c99-input->elf #:key (defines '()) (includes '())) + ((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes)))) + +(define* (c99-input->object #:key (defines '()) (includes '())) + ((compose write-info (c99-input->info #:defines defines #:includes includes)))) + +(define (object->elf info) + ((compose info->elf info:object->text) info)) + +(define (infos->object infos) + ((compose write-info merge-infos) infos)) + +(define (infos->elf infos) + ((compose object->elf merge-infos) infos)) + +(define (merge-infos infos) + (let loop ((infos infos) (info (make ))) + (if (null? infos) info + (loop (cdr infos) + (clone info + #:types (alist-add (.types info) (.types (car infos))) + #:constants (alist-add (.constants info) (.constants (car infos))) + #:functions (alist-add (.functions info) (.functions (car infos))) + #:globals (alist-add (.globals info) (.globals (car infos))) + #:init (append (.init info) (.init (car infos)))))))) + +(define (alist-add a b) + (let* ((b-keys (map car b)) + (a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a)) + (a-keys (map car a))) + (append a (filter (lambda (e) (not (member (car e) a-keys))) b)))) diff --git a/module/language/c99/compiler.scm b/module/language/c99/compiler.scm index a99cfbc4..569beb44 100644 --- a/module/language/c99/compiler.scm +++ b/module/language/c99/compiler.scm @@ -30,13 +30,15 @@ #:use-module (mes elf) #:use-module (mes elf-util) #:use-module (mes as-i386) - #:use-module (mes libc-i386) - #:use-module (mes libc) #:use-module (nyacc lang c99 parser) #:export (c99-input->ast c99-input->elf c99-input->info - info->elf)) + c99-input->object + infos->object + info->elf + infos->elf + object->elf)) (cond-expand (guile-2) diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes index 1af8b211..5dfd2ecd 100644 --- a/module/mes/elf-util.mes +++ b/module/mes/elf-util.mes @@ -46,7 +46,7 @@ ((char? o) (number->string (char->integer o) 16)))) (define (functions->lambdas functions) - (append-map cdr functions)) + (append-map (lambda (f) (or (cdr f) '())) functions)) (define (lambda/label->list f g ta t d) (lambda (l/l) @@ -110,7 +110,7 @@ (define data-offset (let ((cache '())) (lambda (name globals) - (or (assoc-ref cache name) + (or ;;(assoc-ref cache name) (let* ((prefix (member name (reverse globals) (lambda (a b) (equal? (car b) name))))) diff --git a/module/mes/elf.mes b/module/mes/elf.mes index 5b914ca0..20f4c6c0 100644 --- a/module/mes/elf.mes +++ b/module/mes/elf.mes @@ -201,7 +201,7 @@ (define (symbol->table-entry o) (let* ((name (car o)) (offset (function-offset name functions)) - (len (length (text->list (cddr o)))) + (len (if (not (cdr o)) 0 (length (text->list (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))) diff --git a/module/mes/libc-i386.mes b/module/mes/libc-i386.mes index 6f72f54b..2f2ccac5 100644 --- a/module/mes/libc-i386.mes +++ b/module/mes/libc-i386.mes @@ -24,105 +24,112 @@ ;;; Code: -(define (i386:exit f g ta t d) - '( - #x5b ; pop %ebx - #x5b ; pop %ebx - #xb8 #x01 #x00 #x00 #x00 ; mov $0x1,%eax - #xcd #x80 ; int $0x80 - )) +(define i386:exit + '(lambda (f g ta t d) + (list + #x5b ; pop %ebx + #x5b ; pop %ebx + #xb8 #x01 #x00 #x00 #x00 ; mov $0x1,%eax + #xcd #x80 ; int $0x80 + ))) -(define (i386:read f g ta t d) - '( - #x55 ; push %ebp - #x89 #xe5 ; mov %esp,%ebp +(define i386:read + '(lambda (f g ta t d) + (list + #x55 ; push %ebp + #x89 #xe5 ; mov %esp,%ebp - #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx - #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx - #x8b #x55 #x10 ; mov 0x10(%ebp),%edx + #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx + #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx + #x8b #x55 #x10 ; mov 0x10(%ebp),%edx - #xb8 #x03 #x00 #x00 #x00 ; mov $0x3,%eax - #xcd #x80 ; int $0x80 + #xb8 #x03 #x00 #x00 #x00 ; mov $0x3,%eax + #xcd #x80 ; int $0x80 - #xc9 ; leave - #xc3 ; ret - )) + #xc9 ; leave + #xc3 ; ret + ))) -(define (i386:write f g ta t d) - '( - #x55 ; push %ebp - #x89 #xe5 ; mov %esp,%ebp +(define i386:write + '(lambda (f g ta t d) + (list + #x55 ; push %ebp + #x89 #xe5 ; mov %esp,%ebp - #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx - #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx - #x8b #x55 #x10 ; mov 0x10(%ebp),%edx + #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx + #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx + #x8b #x55 #x10 ; mov 0x10(%ebp),%edx - #xb8 #x04 #x00 #x00 #x00 ; mov $0x4,%eax - #xcd #x80 ; int $0x80 + #xb8 #x04 #x00 #x00 #x00 ; mov $0x4,%eax + #xcd #x80 ; int $0x80 - #xc9 ; leave - #xc3 ; ret - )) + #xc9 ; leave + #xc3 ; ret + ))) -(define (i386:open f g ta t d) - '( - #x55 ; push %ebp - #x89 #xe5 ; mov %esp,%ebp +(define i386:open + '(lambda (f g ta t d) + (list + #x55 ; push %ebp + #x89 #xe5 ; mov %esp,%ebp - #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx - #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx - #x8b #x55 #x10 ; mov 0x10(%ebp),%edx + #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx + #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx + #x8b #x55 #x10 ; mov 0x10(%ebp),%edx - #xb8 #x05 #x00 #x00 #x00 ; mov $0x5,%eax - #xcd #x80 ; int $0x80 + #xb8 #x05 #x00 #x00 #x00 ; mov $0x5,%eax + #xcd #x80 ; int $0x80 - #xc9 ; leave - #xc3 ; ret - )) + #xc9 ; leave + #xc3 ; ret + ))) -(define (i386:access f g ta t d) - '( - #x55 ; push %ebp - #x89 #xe5 ; mov %esp,%ebp +(define i386:access + '(lambda (f g ta t d) + (list + #x55 ; push %ebp + #x89 #xe5 ; mov %esp,%ebp - #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx - #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx + #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx + #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx - #xb8 #x21 #x00 #x00 #x00 ; mov $0x21,%eax - #xcd #x80 ; int $0x80 + #xb8 #x21 #x00 #x00 #x00 ; mov $0x21,%eax + #xcd #x80 ; int $0x80 - #xc9 ; leave - #xc3 ; ret - )) + #xc9 ; leave + #xc3 ; ret + ))) -(define (i386:brk f g ta t d) - '( - #x55 ; push %ebp - #x89 #xe5 ; mov %esp,%ebp +(define i386:brk + '(lambda (f g ta t d) + (list + #x55 ; push %ebp + #x89 #xe5 ; mov %esp,%ebp - #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx - #xb8 #x2d #x00 #x00 #x00 ; mov $0x2d,%eax - #xcd #x80 ; int $0x80 + #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx + #xb8 #x2d #x00 #x00 #x00 ; mov $0x2d,%eax + #xcd #x80 ; int $0x80 - #xc9 ; leave - #xc3 ; ret - )) + #xc9 ; leave + #xc3 ; ret + ))) -(define (i386:fsync f g ta t d) - '( - #x55 ; push %ebp - #x89 #xe5 ; mov %esp,%ebp +(define i386:fsync + '(lambda (f g ta t d) + (list + #x55 ; push %ebp + #x89 #xe5 ; mov %esp,%ebp - #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx - #xb8 #x76 #x00 #x00 #x00 ; mov $0x76,%eax - #xcd #x80 ; int $0x80 + #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx + #xb8 #x76 #x00 #x00 #x00 ; mov $0x76,%eax + #xcd #x80 ; int $0x80 - #xc9 ; leave - #xc3 ; ret - )) + #xc9 ; leave + #xc3 ; ret + ))) (define (i386:_start) - (string-append ".byte" + (string-append ".byte" " 0x89 0xe8" ; mov %ebp,%eax " 0x83 0xc0 0x08" ; add $0x8,%eax " 0x50" ; push %eax diff --git a/scripts/mescc.mes b/scripts/mescc.mes index 23f4f032..33b89e5c 100755 --- a/scripts/mescc.mes +++ b/scripts/mescc.mes @@ -37,17 +37,11 @@ exit $r ;;(mes-use-module (language c compiler)) ;;Nyacc -(let* ((files (cddr (command-line))) - (file (if (pair? files) (car files)))) - (cond ((equal? file "--help") - (format (current-error-port) "Usage: mescc.mes [--help|--version|FILE] > a.out\n") - (exit 0)) - ((equal? file "--version") - (format (current-error-port) "mescc.mes (mes) ~a\n" %version) - (exit 0)))) - (mes-use-module (mes guile)) +(mes-use-module (mes getopt-long)) (mes-use-module (language c99 compiler)) +(mes-use-module (srfi srfi-1)) +(mes-use-module (srfi srfi-26)) (format (current-error-port) "mescc.mes...\n") @@ -57,17 +51,76 @@ exit $r (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@")) (define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@")) -(define (main arguments) - (let* ((mfiles (cddr arguments)) - (mfiles (if (or (null? mfiles) (not (equal? (car mfiles) "--"))) mfiles - (cdr mfiles))) - (mfile (if (null? mfiles) (string-append %docdir "examples/main.c") - (car mfiles)))) - (format (current-error-port) "input: ~a\n" mfile) - (with-input-from-file mfile - c99-input->elf))) +(define (parse-opts args) + (let* ((option-spec + '((c (single-char #\c)) + (D (single-char #\D) (value #t)) + (help (single-char #\h)) + (I (single-char #\I) (value #t)) + (o (single-char #\o) (value #t)) + (version (single-char #\V) (value #t)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (files (option-ref options '() '())) + (usage? (and (not help?) (null? files))) + (version? (option-ref options 'version #f))) + (or + (and version? + (format (current-output-port) "mescc.scm (mes) ~a\n" %version)) + (and (or help? usage?) + (format (or (and usage? (current-error-port)) (current-output-port)) "\ +Usage: mescc [OPTION]... FILE... + -c compile and assemble, but do not link + -D DEFINE define DEFINE + -h, --help display this help and exit + -I DIR append DIR to include path + -o FILE write output to FILE + -v, --version display version and exit +") + (exit (or (and usage? 2) 0))) + options))) + +(define (object->info file) + (let* ((string (with-input-from-file file read-string)) + (module (resolve-module '(language c99 compiler)))) + (eval-string string module))) + +(define (object->info file) + (let* ((lst (with-input-from-file file read))) + (primitive-eval lst))) + +(define (source->info defines includes) + (lambda (file) + (with-input-from-file file + (lambda () + ((c99-input->info #:defines defines #:includes includes)))))) + +(define (main args) + (let* ((args (cons* (car args) (cdr (member "--" args)))) + (options (parse-opts args)) + (files (option-ref options '() '())) + (file (if (null? files) (string-append %docdir "examples/main.c") + (car files))) + (compile? (option-ref options 'c #f)) + (sources (filter (cut string-suffix? ".c" <>) files)) + (objects (filter (negate (cut string-suffix? ".c" <>)) files)) + (base (substring file (1+ (or (string-rindex file #\/) -1)) (- (string-length file) 2))) + (out (option-ref options 'o (if compile? (string-append base ".o") "a.out"))) + (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o))))) + (defines (reverse (filter-map (multi-opt 'D) options))) + (includes (reverse (filter-map (multi-opt 'I) options)))) + (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options) + (format (current-error-port) "output: ~a\n" out)) + (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files)) + (format (current-error-port) "inputs: ~a\n" files) + (with-output-to-port (open-output-file out (if compile? S_IRWXU)) + (lambda () + (if (pair? objects) (let ((infos (map object->info objects))) + (if compile? (infos->object infos) + (infos->elf infos))) + (let ((infos (map (source->info defines includes) sources))) + (if compile? (infos->object infos) + (infos->elf infos)))))))) -(format (current-error-port) "compiler loaded\n") -(format (current-error-port) "calling ~s\n" (cons 'main (command-line))) (main (command-line)) ()