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.
This commit is contained in:
Jan Nieuwenhuizen
parent
bdd160241b
commit
2027754a59
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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: <type> 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 <info>
|
||||
#: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 <info>\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 <info>
|
||||
#: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 <info>)))
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
()
|
||||
|
|
|
|||
Loading…
Reference in a new issue