artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: support -c, -o.

Browse source 
* 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 2017-05-17 13:56:25 +02:00
parent bdd160241b
commit 2027754a59
9 changed files with 533 additions and 312 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

96
guile/mescc.scm
View file

@ -2,8 +2,8 @@
# -*-scheme-*- # -*-scheme-*-
GODIR=${GODIR-@GODIR@} GODIR=${GODIR-@GODIR@}
GUILEDIR=${GUILEDIR-@GUILEDIR@} GUILEDIR=${GUILEDIR-@GUILEDIR@}
[ "$GODIR" = @"GODIR"@ ] && GODIR=guile [ "$GODIR" = @"GODIR"@ ] && GODIR=$(dirname $0)
[ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=guile [ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=$(dirname $0)
export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0} export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0}
exec ${GUILE-guile} -L $GUILEDIR -C $GODIR -e '(mescc)' -s "$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) (define-module (mescc)
#:use-module (language c99 compiler) #:use-module (language c99 compiler)
#:use-module (ice-9 rdelim) #:use-module (ice-9 getopt-long)
#:use-module (ice-9 pretty-print) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (main)) #:export (main))
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@")) (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)) '%prefix %prefix)
(module-define! (resolve-module '(language c99 compiler)) '%version %version) (module-define! (resolve-module '(language c99 compiler)) '%version %version)
(define (main arguments) (define (parse-opts args)
(let* ((files (cdr arguments)) (let* ((option-spec
(file (if (null? files) (string-append %docdir "examples/main.c") '((c (single-char #\c))
(car files)))) (D (single-char #\D) (value #t))
(cond ((equal? file "--help") (help (single-char #\h))
(format (current-error-port) "Usage: mescc.scm [--help|--version|FILE] > a.out\n") (I (single-char #\I) (value #t))
(exit 0)) (o (single-char #\o) (value #t))
((equal? file "--version") (version (single-char #\V) (value #t))))
(format (current-error-port) "mescc.scm (mes) ~a\n" %version) (options (getopt-long args option-spec))
(exit 0))) (help? (option-ref options 'help #f))
(format (current-error-port) "input: ~a\n" file) (files (option-ref options '() '()))
(with-input-from-file file (usage? (and (not help?) (null? files)))
c99-input->elf))) (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") (define (object->info file)
(format (current-error-port) "calling ~s\n" (cons 'main (command-line))) (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))))

2
make/mescc-guile.make
View file

@ -5,6 +5,6 @@ $(OUT)/$(TARGET): $(INSTALL_GO_FILES)
$(OUT)/$(TARGET): $(C_FILES) $(OUT)/$(TARGET): $(C_FILES)
@echo " mescc.scm $(notdir $<) -> $(notdir $@)" @echo " mescc.scm $(notdir $<) -> $(notdir $@)"
@rm -f $@ @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 $@ ||: @[ -f $@ ] && chmod +x $@ ||:
include make/reset.make include make/reset.make

3
make/mescc-mes.make
View file

@ -2,6 +2,7 @@ CLEAN+=$(OUT)/$(TARGET)
ifneq ($(MES_MAX_ARENA),) ifneq ($(MES_MAX_ARENA),)
$(OUT)/$(TARGET): MES_MAX_ARENA-flag:=MES_MAX_ARENA=$(MES_MAX_ARENA) $(OUT)/$(TARGET): MES_MAX_ARENA-flag:=MES_MAX_ARENA=$(MES_MAX_ARENA)
endif endif
$(OUT)/$(TARGET): C_INCLUDE_PATH:=$(INCLUDES)
$(OUT)/$(TARGET): $(MAKEFILE_LIST) $(OUT)/$(TARGET): $(MAKEFILE_LIST)
$(OUT)/$(TARGET): module/mes/read-0.mo $(OUT)/$(TARGET): module/mes/read-0.mo
$(OUT)/$(TARGET): module/mes/read-0-32.mo $(OUT)/$(TARGET): module/mes/read-0-32.mo
@ -10,6 +11,6 @@ $(OUT)/$(TARGET): scripts/mes
$(OUT)/$(TARGET): $(C_FILES) $(OUT)/$(TARGET): $(C_FILES)
@echo " mescc.mes $(notdir $<) -> $(notdir $@)" @echo " mescc.mes $(notdir $<) -> $(notdir $@)"
@rm -f $@ @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 $@ ||: @[ -f $@ ] && chmod +x $@ ||:
include make/reset.make include make/reset.make

480
module/language/c99/compiler.mes
View file

@ -54,9 +54,9 @@
(define mes? (pair? (current-module))) (define mes? (pair? (current-module)))
(define (c99-input->ast) (define* (c99-input->ast #:key (defines '()) (includes '()))
(parse-c99 (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 `( #:cpp-defs `(
"POSIX=0" "POSIX=0"
"_POSIX_SOURCE=0" "_POSIX_SOURCE=0"
@ -81,6 +81,7 @@
,(string-append "PREFIX=\"" %prefix "\"") ,(string-append "PREFIX=\"" %prefix "\"")
,(string-append "MODULEDIR=\"" %moduledir "\"") ,(string-append "MODULEDIR=\"" %moduledir "\"")
,(string-append "VERSION=\"" %version "\"") ,(string-append "VERSION=\"" %version "\"")
,@defines
) )
#:mode 'code)) #:mode 'code))
@ -203,8 +204,8 @@
(define (push-global globals) (define (push-global globals)
(lambda (o) (lambda (o)
(list (list
(lambda (f g ta t d) `(lambda (f g ta t d)
(i386:push-global (+ (data-offset o g) d)))))) (i386:push-global (+ (data-offset ,o g) d))))))
(define (push-local locals) (define (push-local locals)
(lambda (o) (lambda (o)
@ -213,8 +214,8 @@
(define (push-global-address globals) (define (push-global-address globals)
(lambda (o) (lambda (o)
(list (list
(lambda (f g ta t d) `(lambda (f g ta t d)
(i386:push-global-address (+ (data-offset o g) d)))))) (i386:push-global-address (+ (data-offset ,o g) d))))))
(define (push-local-address locals) (define (push-local-address locals)
(lambda (o) (lambda (o)
@ -362,18 +363,18 @@
(size (if (= ptr 1) (type->size info type) (size (if (= ptr 1) (type->size info type)
4))) 4)))
(case ptr (case ptr
((-1) (list (lambda (f g ta t d) ((-1) (list `(lambda (f g ta t d)
(i386:global->accu (+ (data-offset o g) d))))) (i386:global->accu (+ (data-offset ,o g) d)))))
((1) (list (lambda (f g ta t d) ((1) (list `(lambda (f g ta t d)
(i386:global-address->accu (+ (data-offset o g) d))))) (i386:global-address->accu (+ (data-offset ,o g) d)))))
((2) (list (lambda (f g ta t d) ((2) (list `(lambda (f g ta t d)
(append (i386:value->accu (+ (data-offset o g) d)))))) (append (i386:value->accu (+ (data-offset ,o g) d))))))
(else (list (lambda (f g ta t d) (else (list `(lambda (f g ta t d)
(i386:global-address->accu (+ (data-offset o g) d))))))) (i386:global-address->accu (+ (data-offset ,o g) d)))))))
(if constant (wrap-as (i386:value->accu constant)) (if constant (wrap-as (i386:value->accu constant))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:global->accu (+ ta (function-offset o f))))))))))) (i386:global->accu (+ ta (function-offset ,o f)))))))))))
(define (ident-address->accu info) (define (ident-address->accu info)
(lambda (o) (lambda (o)
@ -391,12 +392,12 @@
(let ((ptr (ident->pointer info o))) (let ((ptr (ident->pointer info o)))
(case ptr (case ptr
;; ((1) ;; ((1)
;; (list (lambda (f g ta t d) ;; (list `(lambda (f g ta t d)
;; (i386:global->accu (+ (data-offset o g) d))))) ;; (i386:global->accu (+ (data-offset ,o g) d)))))
(else (list (lambda (f g ta t d) (else (list `(lambda (f g ta t d)
(append (i386:value->accu (+ (data-offset o g) d)))))))) (append (i386:value->accu (+ (data-offset ,o g) d))))))))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:global->accu (+ ta (function-offset o f)))))))))) (i386:global->accu (+ ta (function-offset ,o f))))))))))
(define (ident-address->base info) (define (ident-address->base info)
(lambda (o) (lambda (o)
@ -413,10 +414,10 @@
(let ((ptr (ident->pointer info o))) (let ((ptr (ident->pointer info o)))
(case ptr (case ptr
((1) ((1)
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:global->base (+ (data-offset o g) d))))) (i386:global->base (+ (data-offset ,o g) d)))))
(else (list (lambda (f g ta t d) (else (list `(lambda (f g ta t d)
(append (i386:value->base (+ (data-offset o g) d)))))))) (append (i386:value->base (+ (data-offset ,o g) d))))))))
(error "TODO ident-address->base" o)))))) (error "TODO ident-address->base" o))))))
(define (value->accu v) (define (value->accu v)
@ -430,15 +431,15 @@
(case ptr (case ptr
(else (wrap-as (i386:accu->local (local:id local)))))) (else (wrap-as (i386:accu->local (local:id local))))))
(let ((ptr (ident->pointer info o))) (let ((ptr (ident->pointer info o)))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:accu->global (+ (data-offset o g) d))))))))) (i386:accu->global (+ (data-offset ,o g) d)))))))))
(define (base->ident info) (define (base->ident info)
(lambda (o) (lambda (o)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:base->local (local:id local))) (if local (wrap-as (i386:base->local (local:id local)))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:base->global (+ (data-offset o g) d)))))))) (i386:base->global (+ (data-offset ,o g) d))))))))
(define (base->ident-address info) (define (base->ident-address info)
(lambda (o) (lambda (o)
@ -457,15 +458,15 @@
(lambda (o value) (lambda (o value)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:value->local (local:id local) value)) (if local (wrap-as (i386:value->local (local:id local) value))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:value->global (+ (data-offset o g) d) value))))))) (i386:value->global (+ (data-offset ,o g) d) value)))))))
(define (ident-add info) (define (ident-add info)
(lambda (o n) (lambda (o n)
(let ((local (assoc-ref (.locals info) o))) (let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:local-add (local:id local) n)) (if local (wrap-as (i386:local-add (local:id local) n))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:global-add (+ (data-offset o g) d) n))))))) (i386:global-add (+ (data-offset ,o g) d) ,n)))))))
(define (ident-address-add info) (define (ident-address-add info)
(lambda (o n) (lambda (o n)
@ -474,10 +475,10 @@
(i386:local->accu (local:id local)) (i386:local->accu (local:id local))
(i386:accu-mem-add n) (i386:accu-mem-add n)
(i386:pop-accu))) (i386:pop-accu)))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(append (i386:push-accu) (append (i386:push-accu)
(i386:global->accu (+ (data-offset o g) d)) (i386:global->accu (+ (data-offset ,o g) d))
(i386:accu-mem-add n) (i386:accu-mem-add ,n)
(i386:pop-accu)))))))) (i386:pop-accu))))))))
;; FIXME: see ident->accu ;; FIXME: see ident->accu
@ -499,16 +500,16 @@
(if global (if global
(let ((ptr (ident->pointer info o))) (let ((ptr (ident->pointer info o)))
(case ptr (case ptr
((-1) (list (lambda (f g ta t d) ((-1) (list `(lambda (f g ta t d)
(i386:global->base (+ (data-offset o g) d))))) (i386:global->base (+ (data-offset ,o g) d)))))
((2) (list (lambda (f g ta t d) ((2) (list `(lambda (f g ta t d)
(i386:global->base (+ (data-offset o g) d))))) (i386:global->base (+ (data-offset ,o g) d)))))
(else (list (lambda (f g ta t d) (else (list `(lambda (f g ta t d)
(i386:global-address->base (+ (data-offset o g) d))))))) (i386:global-address->base (+ (data-offset ,o g) d)))))))
(let ((constant (assoc-ref (.constants info) o))) (let ((constant (assoc-ref (.constants info) o)))
(if constant (wrap-as (i386:value->base constant)) (if constant (wrap-as (i386:value->base constant))
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:global->base (+ ta (function-offset o f))))))))))))) (i386:global->base (+ ta (function-offset ,o f)))))))))))))
(define (expr->accu info) (define (expr->accu info)
(lambda (o) (lambda (o)
@ -526,12 +527,12 @@
((p-expr (string ,string)) ((p-expr (string ,string))
(let* ((globals (append globals (list (string->global string)))) (let* ((globals (append globals (list (string->global string))))
(info (clone info #:globals globals))) (info (clone info #:globals globals)))
(append-text info (list (lambda (f g ta t d) (append-text info (list `(lambda (f g ta t d)
(i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))) (i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))))
((p-expr (string . ,strings)) ((p-expr (string . ,strings))
(append-text info (list (lambda (f g ta t d) (append-text info (list `(lambda (f g ta t d)
(i386:global->accu (+ (data-offset (add-s:-prefix (apply string-append strings)) globals) d)))))) (i386:global->accu (+ (data-offset ,(add-s:-prefix (apply string-append strings)) g) d))))))
((p-expr (fixed ,value)) ((p-expr (fixed ,value))
(append-text info (value->accu (cstring->number value)))) (append-text info (value->accu (cstring->number value))))
@ -663,14 +664,14 @@
(loop (cdr expressions) ((expr->arg info) (car expressions)))))) (loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list))) (n (length expr-list)))
(if (and (not (assoc-ref locals name)) (if (and (not (assoc-ref locals name))
(assoc-ref (.functions info) name)) (assoc name (.functions info)))
(append-text args-info (list (lambda (f g ta t d) (append-text args-info (list `(lambda (f g ta t d)
(i386:call f g ta t d (+ t (function-offset name f)) n)))) (i386:call f g ta t d (+ t (function-offset ,name f)) ,n))))
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) `(p-expr (ident ,name))))) (accu ((expr->accu empty) `(p-expr (ident ,name)))))
(append-text args-info (append (.text accu) (append-text args-info (append (.text accu)
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:call-accu f g ta t d n)))))))))) (i386:call-accu f g ta t d ,n))))))))))
((fctn-call ,function (expr-list . ,expr-list)) ((fctn-call ,function (expr-list . ,expr-list))
(let* ((text-length (length text)) (let* ((text-length (length text))
@ -681,8 +682,8 @@
(empty (clone info #:text '())) (empty (clone info #:text '()))
(accu ((expr->accu empty) function))) (accu ((expr->accu empty) function)))
(append-text args-info (append (.text accu) (append-text args-info (append (.text accu)
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(i386:call-accu f g ta t d n))))))) (i386:call-accu f g ta t d ,n)))))))
((cond-expr . ,cond-expr) ((cond-expr . ,cond-expr)
((ast->info info) `(expr-stmt ,o))) ((ast->info info) `(expr-stmt ,o)))
@ -859,7 +860,7 @@
(clone info #:text (append (.text info) text))) (clone info #:text (append (.text info) text)))
(define (wrap-as o) (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) (define (expr->accu* info)
(lambda (o) (lambda (o)
@ -966,9 +967,9 @@
(_ (error "case test: unsupported: " test))))) (_ (error "case test: unsupported: " test)))))
(lambda (n) (lambda (n)
(append (wrap-as (i386:accu-cmp-value value)) (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 (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) (define (cases+jump cases clause-length)
(append-text info (append-text info
(append (append
@ -992,7 +993,7 @@
(() (()
(let* ((cases-length (length (.text (cases+jump cases 0)))) (let* ((cases-length (length (.text (cases+jump cases 0))))
(clause-text (list-tail (.text clause) cases-length)) (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 (clone clause #:text
(append (.text (cases+jump cases clause-length)) (append (.text (cases+jump cases clause-length))
clause-text)))) clause-text))))
@ -1038,11 +1039,11 @@
(a-jump ((test->jump->info info) a)) (a-jump ((test->jump->info info) a))
(a-text (.text (a-jump 0))) (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-jump ((test->jump->info info) b))
(b-text (.text (b-jump 0))) (b-text (.text (b-jump 0)))
(b-length (length (text->list b-text)))) (b-length (length (object->list b-text))))
(lambda (body-length) (lambda (body-length)
(let* ((info (append-text info text)) (let* ((info (append-text info text))
@ -1062,14 +1063,14 @@
(a-jump ((test->jump->info info) a)) (a-jump ((test->jump->info info) a))
(a-text (.text (a-jump 0))) (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-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-jump ((test->jump->info info) b))
(b-text (.text (b-jump 0))) (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)))) (jump-text (wrap-as (i386:Xjump b-length))))
@ -1225,7 +1226,8 @@
(define (ast->info info) (define (ast->info info)
(lambda (o) (lambda (o)
(let ((globals (.globals info)) (let ((functions (.functions info))
(globals (.globals info))
(locals (.locals info)) (locals (.locals info))
(constants (.constants info)) (constants (.constants info))
(text (.text info))) (text (.text info)))
@ -1234,6 +1236,9 @@
(1+ (local:id (cdar locals))))) (1+ (local:id (cdar locals)))))
(locals (cons (make-local name type pointer id) locals))) (locals (cons (make-local name type pointer id) locals)))
locals)) locals))
(define (declare name)
(if (member name functions) info
(clone info #:functions (cons (cons name #f) functions))))
(pmatch o (pmatch o
(((trans-unit . _) . _) (((trans-unit . _) . _)
((ast-list->info info) o)) ((ast-list->info info) o))
@ -1248,7 +1253,7 @@
info) info)
((break) ((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? ;; FIXME: expr-stmt wrapper?
(trans-unit info) (trans-unit info)
@ -1266,7 +1271,7 @@
(body-info ((ast->info test+jump-info) body)) (body-info ((ast->info test+jump-info) body))
(text-body-info (.text body-info)) (text-body-info (.text body-info))
(body-text (list-tail text-body-info test-length)) (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))) (text+test-text (.text (test-jump->info body-length)))
(test-text (list-tail text+test-text text-length))) (test-text (list-tail text+test-text text-length)))
@ -1288,14 +1293,14 @@
(text-then-info (.text then-info)) (text-then-info (.text then-info))
(then-text (list-tail text-then-info test-length)) (then-text (list-tail text-then-info test-length))
(then-jump-text (wrap-as (i386:Xjump 0))) (then-jump-text (wrap-as (i386:Xjump 0)))
(then-jump-length (length (text->list then-jump-text))) (then-jump-length (length (object->list then-jump-text)))
(then-length (+ (length (text->list then-text)) then-jump-length)) (then-length (+ (length (object->list then-text)) then-jump-length))
(then+jump-info (clone then-info #:text (append text-then-info then-jump-text))) (then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
(else-info ((ast->info then+jump-info) else)) (else-info ((ast->info then+jump-info) else))
(text-else-info (.text else-info)) (text-else-info (.text else-info))
(else-text (list-tail text-else-info (length (.text then+jump-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))) (text+test-text (.text (test-jump->info then-length)))
(test-text (list-tail text+test-text text-length)) (test-text (list-tail text+test-text text-length))
@ -1321,10 +1326,10 @@
(then-info ((ast->info test+jump-info) then)) (then-info ((ast->info test+jump-info) then))
(text-then-info (.text then-info)) (text-then-info (.text then-info))
(then-text (list-tail text-then-info test-length)) (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-text (wrap-as (i386:Xjump 0)))
(jump-length (length (text->list jump-text))) (jump-length (length (object->list jump-text)))
(test+then+jump-info (test+then+jump-info
(clone then-info (clone then-info
@ -1333,7 +1338,7 @@
(else-info ((ast->info test+then+jump-info) else)) (else-info ((ast->info test+then+jump-info) else))
(text-else-info (.text else-info)) (text-else-info (.text else-info))
(else-text (list-tail text-else-info (length (.text test+then+jump-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)))) (text+test-text (.text (test-jump->info (+ then-length jump-length))))
(test-text (list-tail text+test-text text-length)) (test-text (list-tail text+test-text text-length))
@ -1352,7 +1357,7 @@
(expr ((expr->accu info) expr)) (expr ((expr->accu info) expr))
(empty (clone info #:text '())) (empty (clone info #:text '()))
(clause-infos (map (clause->jump-info empty) clauses)) (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)) (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
(if (null? clauses) info (if (null? clauses) info
(let ((c-j ((clause->jump-info info) (car clauses)))) (let ((c-j ((clause->jump-info info) (car clauses))))
@ -1370,20 +1375,20 @@
(body-info ((ast->info info) body)) (body-info ((ast->info info) body))
(body-text (.text body-info)) (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-info ((expr->accu info) step))
(step-text (.text step-info)) (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 info) test))
(test+jump-info (test-jump->info 0)) (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)))) (skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
(jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-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)))) (test-text (.text (test-jump->info jump-length))))
@ -1402,7 +1407,7 @@
(let* ((skip-info (lambda (body-length test-length) (let* ((skip-info (lambda (body-length test-length)
(clone info (clone info
#:text (append text (wrap-as (i386:Xjump body-length))) #: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))) (length (i386:Xjump 0)))
(.break info))))) (.break info)))))
(text (.text (skip-info 0 0))) (text (.text (skip-info 0 0)))
@ -1411,19 +1416,19 @@
((ast->info (skip-info body-length test-length)) body))) ((ast->info (skip-info body-length test-length)) body)))
(body-text (list-tail (.text (body-info 0 0)) text-length)) (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 '())) (empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test)) (test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0)) (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-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))) (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 (clone info #:text
(append (append
@ -1437,15 +1442,15 @@
(body-info ((ast->info info) body)) (body-info ((ast->info info) body))
(body-text (list-tail (.text body-info) text-length)) (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 '())) (empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test)) (test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0)) (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-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)))) (test-text (.text (test-jump->info jump-length))))
(clone info #:text (clone info #:text
@ -1461,10 +1466,10 @@
((goto (ident ,label)) ((goto (ident ,label))
(let* ((jump (lambda (n) (i386:XXjump n))) (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 (append-text info (append
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(jump (- (label-offset (.function info) label f) offset)))))))) (i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
((return ,expr) ((return ,expr)
(let ((info ((expr->accu info) expr))) (let ((info ((expr->accu info) expr)))
@ -1526,25 +1531,26 @@
(globals (append globals (list (string->global string)))) (globals (append globals (list (string->global string))))
(info (clone info #:locals locals #:globals globals))) (info (clone info #:locals locals #:globals globals)))
(append-text info (append (append-text info (append
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(append (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)))) ((accu->ident info) name))))
(let* ((global (string->global string)) (let* ((global (string->global string))
(globals (append globals (list global))) (globals (append globals (list global)))
(size 4) (size 4)
(global (make-global name type 1 (string->list (make-string size #\nul)))) (global (make-global name type 1 (string->list (make-string size #\nul))))
(globals (append globals (list global))) (globals (append globals (list global)))
(info (clone info #:globals globals)) (info (clone info #:globals globals)))
(here (data-offset name globals)))
(clone info #:init (clone info #:init
(append (append
(.init info) (.init info)
(list (lambda (functions globals ta t d data) (list
(append `(lambda (f g ta t d data)
(list-head data here) (let (((here (data-offset ,name g))))
(initzer->data info functions globals ta t d `(initzer (p-expr (string ,string)))) (append
(list-tail data (+ here size)))))))))) (list-head data here)
(initzer->data f g ta t d '(initzer (p-expr (string ,string))))
(list-tail data (+ here ,size)))))))))))
;; char const *p; ;; 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))))) ((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) ((ident->accu info) b)
((accu->ident info) name)))) ((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 2 0)))) (let* ((globals (append globals (list (ident->global name type 2 0))))
(here (data-offset name globals))) (value (assoc-ref constants b)))
(clone info (clone info
#:globals globals #:globals globals
#:init (append (.init info) #:init (append (.init info)
(list (lambda (functions globals ta t d data) (list
(append `(lambda (f g ta t d data)
(list-head data here) (let ((here (data-offset ,name g)))
;;(initzer->data info functions globals ta t d initzer) (append
(initzer->data info functions globals ta t d `(p-expr (ident ,b))) (list-head data here)
(list-tail data (+ here 4)))))))) (initzer->data f g ta t d '(p-expr (fixed ,value)))
;;;(clone info #:globals (append globals (list (ident->global name type 1 0)))) (list-tail data (+ here 4)))))))))))
))
;; struct foo bar[2]; ;; struct foo bar[2];
;; char arena[20000]; ;; char arena[20000];
@ -1715,7 +1720,7 @@
(append text (append text
(.text accu) (.text accu)
((accu->ident info) name) ((accu->ident info) name)
(list (lambda (f g ta t d) (list `(lambda (f g ta t d)
(append (i386:value->base ta) (append (i386:value->base ta)
(i386:accu+base))))) (i386:accu+base)))))
#:locals locals))) #:locals locals)))
@ -1727,21 +1732,22 @@
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) value) (append-text info (append ((ident->accu info) value)
((accu->ident info) name)))) ((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0)))) (let* ((globals (append globals (list (ident->global name type 1 0)))))
(here (data-offset name globals))
(there (data-offset value globals)))
(clone info (clone info
#:globals globals #:globals globals
#:init (append (.init info) #:init (append (.init info)
(list (lambda (functions globals ta t d data) (list
(append `(lambda (f g ta t d data)
(list-head data here) (let ((here (data-offset ,name g))
;;; FIXME: type (there (data-offset ,value g)))
;;; char *x = arena; (append
(int->bv32 (+ d (data-offset value globals))) (list-head data here)
;;; char *y = x; ;; FIXME: type
;;;(list-head (list-tail data there) 4) ;; char *x = arena;
(list-tail data (+ here 4)))))))))) (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; ;; 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)))))) ((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))) (info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) value) (append-text info (append ((ident->accu info) value)
((accu->ident info) name)))) ((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0)))) (let* ((globals (append globals (list (ident->global name type 1 0)))))
(here (data-offset name globals)))
(clone info (clone info
#:globals globals #:globals globals
#:init (append (.init info) #:init (append (.init info)
(list (lambda (functions globals ta t d data) (list `(lambda (f g ta t d data)
(append (let ((here (data-offset ,name g)))
(list-head data here) (append
;;; FIXME: type (list-head data here)
;;; char *x = arena;p ;; FIXME: type
(int->bv32 (+ d (data-offset value globals))) ;; char *x = arena;p
(list-tail data (+ here 4))))))))))) (int->bv32 (+ d (data-offset ,value g)))
(list-tail data (+ here 4))))))))))))
;; enum ;; enum
((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields))))) ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
@ -1857,24 +1863,26 @@
(let* ((type (decl->type type)) (let* ((type (decl->type type))
(entries (map initzer->global initzers)) (entries (map initzer->global initzers))
(entry-size 4) (entry-size 4)
(size (* (length entries) entry-size))) (size (* (length entries) entry-size))
(initzers (map (initzer->non-const info) initzers)))
(if (.function info) (if (.function info)
(error "TODO: <type> x[] = {};" o) (error "TODO: <type> x[] = {};" o)
(let* ((global (make-global name type 2 (string->list (make-string size #\nul)))) (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
(globals (append globals entries (list global))) (globals (append globals entries (list global)))
(info (clone info #:globals globals)) (info (clone info #:globals globals)))
(here (data-offset name globals)))
(clone info #:init (clone info #:init
(append (append
(.init info) (.init info)
(list (lambda (functions globals ta t d data) (list
(append `(lambda (f g ta t d data)
(list-head data here) (let ((here (data-offset ,name g)))
(append-map (append
(lambda (i) (list-head data here)
(initzer->data info functions globals ta t d i)) (append-map
initzers) (lambda (i)
(list-tail data (+ here size))))))))))) (initzer->data f g ta t d i))
',initzers)
(list-tail data (+ here ,size))))))))))))
;; ;;
;; struct f = {...}; ;; struct f = {...};
@ -1882,7 +1890,8 @@
(let* ((type (decl->type type)) (let* ((type (decl->type type))
(fields (type->description info type)) (fields (type->description info type))
(size (type->size 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) (if (.function info)
(let* ((globals (append globals (filter-map initzer->global initzers))) (let* ((globals (append globals (filter-map initzer->global initzers)))
(locals (let loop ((fields (cdr fields)) (locals locals)) (locals (let loop ((fields (cdr fields)) (locals locals))
@ -1906,7 +1915,6 @@
(let* ((globals (append globals (filter-map initzer->global initzers))) (let* ((globals (append globals (filter-map initzer->global initzers)))
(global (make-global name type -1 (string->list (make-string size #\nul)))) (global (make-global name type -1 (string->list (make-string size #\nul))))
(globals (append globals (list global))) (globals (append globals (list global)))
(here (data-offset name globals))
(info (clone info #:globals globals)) (info (clone info #:globals globals))
(field-size 4)) (field-size 4))
(let loop ((fields (iota (length fields))) (initzers initzers) (info info)) (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
@ -1917,39 +1925,43 @@
(clone info #:init (clone info #:init
(append (append
(.init info) (.init info)
(list (lambda (functions globals ta t d data) (list
(append `(lambda (f g ta t d data)
(list-head data (+ here offset)) (let ((here (data-offset ,name g)))
(initzer->data info functions globals ta t d (car initzers)) (append
(list-tail data (+ here offset field-size))))))))))))))) (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? ;;char cc = g_cells[c].cdr; ==> generic?
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer)))) ((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) (if (.function info)
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (clone info #:text
(append (.text ((expr->accu info) initzer)) (append (.text ((expr->accu info) initzer))
((accu->ident info) name)))) ((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0)))) (let* ((globals (append globals (list (ident->global name type 1 0)))))
(here (data-offset name globals)))
(clone info (clone info
#:globals globals #:globals globals
#:init (append (.init info) #:init (append (.init info)
(list (lambda (functions globals ta t d data) (list
(append `(lambda (f g ta t d data)
(list-head data here) (let ((here (data-offset ,name g)))
(initzer->data info functions globals ta t d initzer) (append
(list-tail data (+ here 4))))))))))) (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))))) ((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)) ((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)))) ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(let ((types (.types info))) (let ((types (.types info)))
@ -1957,23 +1969,23 @@
;; int foo (); ;; int foo ();
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) ((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 (); ;; void foo ();
((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) ((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 (*); ;; 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)))))) ((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 (); ;; 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)))))) ((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 (); ;; 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)))))) ((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, ...) ;; 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)))))) ((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))) (_ (let ((info ((expr->accu info) o)))
(append-text info (wrap-as (i386:accu-zero?))))))))) (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 (pmatch o
((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value))) ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
((initzer (neg (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)))) ((initzer (ref-to (p-expr (ident ,name))))
(int->bv32 (+ ta (function-offset name functions)))) (int->bv32 (+ ta (function-offset name f))))
((initzer (p-expr (ident ,name)))
(let ((value (assoc-ref (.constants info) name)))
(int->bv32 value)))
((initzer (p-expr (string ,string))) ((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)))) (_ (error "initzer->data: unsupported: " o))))
(define (.formals o) (define (.formals o)
@ -2080,7 +2097,7 @@
(define (assert-return text) (define (assert-return text)
(let ((return (wrap-as (i386:ret)))) (let ((return (wrap-as (i386:ret))))
(if (equal? (list-tail text (- (length text) (length return))) return) text (if (equal? (list-tail text (- (length text) (length return))) return) text
(append text (wrap-as (i386:ret)))))) (append text return))))
(let* ((name (.name o)) (let* ((name (.name o))
(formals (.formals o)) (formals (.formals o))
(text (formals->text formals)) (text (formals->text formals))
@ -2088,9 +2105,9 @@
(format (current-error-port) "compiling: ~a\n" name) (format (current-error-port) "compiling: ~a\n" name)
(let loop ((statements (.statements o)) (let loop ((statements (.statements o))
(info (clone info #:locals locals #:function (.name o) #:text text))) (info (clone info #:locals locals #:function (.name o) #:text text)))
(if (null? statements) (assert-return (clone info (if (null? statements) (clone info
#:function #f #:function #f
#:functions (append (.functions info) (list (cons name (assert-return (.text info))))))) #:functions (append (.functions info) (list (cons name (assert-return (.text info))))))
(let* ((statement (car statements))) (let* ((statement (car statements)))
(loop (cdr statements) (loop (cdr statements)
((ast->info info) (car statements))))))))) ((ast->info info) (car statements)))))))))
@ -2101,20 +2118,63 @@
(if (null? elements) info (if (null? elements) info
(loop (cdr elements) ((ast->info info) (car elements))))))) (loop (cdr elements) ((ast->info info) (car elements)))))))
(define (c99-input->info) (define current-eval
(let* ((info (make <info> (let ((module (current-module)))
#:functions i386:libc (lambda (e) (eval e module))))
#:types i386:type-alist))
(foo (stderr "compiling: mlibc\n")) (define (object->list object)
(info (let loop ((info info) (libc libc)) (text->list (map current-eval object)))
(if (null? libc) info
(loop ((ast->info info) ((car libc))) (cdr libc))))) (define (dec->xhex o)
(foo (stderr "parsing: input\n")) (string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
(ast (c99-input->ast))
(foo (stderr "compiling: input\n")) (define (write-lambda o)
(info ((ast->info info) ast)) (newline)
(info ((ast->info info) (_start)))) (display " ")
info)) (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) (define (write-any x)
(write-char (cond ((char? x) x) (write-char (cond ((char? x) x)
@ -2129,7 +2189,47 @@
(define (info->elf info) (define (info->elf info)
(display "dumping elf\n" (current-error-port)) (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) (define (function:object->text o)
((compose info->elf c99-input->info))) (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))))

8
module/language/c99/compiler.scm
View file

@ -30,13 +30,15 @@
#:use-module (mes elf) #:use-module (mes elf)
#:use-module (mes elf-util) #:use-module (mes elf-util)
#:use-module (mes as-i386) #:use-module (mes as-i386)
#:use-module (mes libc-i386)
#:use-module (mes libc)
#:use-module (nyacc lang c99 parser) #:use-module (nyacc lang c99 parser)
#:export (c99-input->ast #:export (c99-input->ast
c99-input->elf c99-input->elf
c99-input->info c99-input->info
info->elf)) c99-input->object
infos->object
info->elf
infos->elf
object->elf))
(cond-expand (cond-expand
(guile-2) (guile-2)

4
module/mes/elf-util.mes
View file

@ -46,7 +46,7 @@
((char? o) (number->string (char->integer o) 16)))) ((char? o) (number->string (char->integer o) 16))))
(define (functions->lambdas functions) (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) (define (lambda/label->list f g ta t d)
(lambda (l/l) (lambda (l/l)
@ -110,7 +110,7 @@
(define data-offset (define data-offset
(let ((cache '())) (let ((cache '()))
(lambda (name globals) (lambda (name globals)
(or (assoc-ref cache name) (or ;;(assoc-ref cache name)
(let* ((prefix (member name (reverse globals) (let* ((prefix (member name (reverse globals)
(lambda (a b) (lambda (a b)
(equal? (car b) name))))) (equal? (car b) name)))))

2
module/mes/elf.mes
View file

@ -201,7 +201,7 @@
(define (symbol->table-entry o) (define (symbol->table-entry o)
(let* ((name (car o)) (let* ((name (car o))
(offset (function-offset name functions)) (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)))))) (str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car functions))))))
(i (1+ (length str)))) (i (1+ (length str))))
(symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1))) (symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1)))

157
module/mes/libc-i386.mes
View file

@ -24,105 +24,112 @@
;;; Code: ;;; Code:
(define (i386:exit f g ta t d) (define i386:exit
'( '(lambda (f g ta t d)
#x5b ; pop %ebx (list
#x5b ; pop %ebx #x5b ; pop %ebx
#xb8 #x01 #x00 #x00 #x00 ; mov $0x1,%eax #x5b ; pop %ebx
#xcd #x80 ; int $0x80 #xb8 #x01 #x00 #x00 #x00 ; mov $0x1,%eax
)) #xcd #x80 ; int $0x80
)))
(define (i386:read f g ta t d) (define i386:read
'( '(lambda (f g ta t d)
#x55 ; push %ebp (list
#x89 #xe5 ; mov %esp,%ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp
#x8b #x5d #x08 ; mov 0x8(%ebp),%ebx #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx
#x8b #x4d #x0c ; mov 0xc(%ebp),%ecx #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx
#x8b #x55 #x10 ; mov 0x10(%ebp),%edx #x8b #x55 #x10 ; mov 0x10(%ebp),%edx
#xb8 #x03 #x00 #x00 #x00 ; mov $0x3,%eax #xb8 #x03 #x00 #x00 #x00 ; mov $0x3,%eax
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
)) )))
(define (i386:write f g ta t d) (define i386:write
'( '(lambda (f g ta t d)
#x55 ; push %ebp (list
#x89 #xe5 ; mov %esp,%ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp
#x8b #x5d #x08 ; mov 0x8(%ebp),%ebx #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx
#x8b #x4d #x0c ; mov 0xc(%ebp),%ecx #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx
#x8b #x55 #x10 ; mov 0x10(%ebp),%edx #x8b #x55 #x10 ; mov 0x10(%ebp),%edx
#xb8 #x04 #x00 #x00 #x00 ; mov $0x4,%eax #xb8 #x04 #x00 #x00 #x00 ; mov $0x4,%eax
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
)) )))
(define (i386:open f g ta t d) (define i386:open
'( '(lambda (f g ta t d)
#x55 ; push %ebp (list
#x89 #xe5 ; mov %esp,%ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp
#x8b #x5d #x08 ; mov 0x8(%ebp),%ebx #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx
#x8b #x4d #x0c ; mov 0xc(%ebp),%ecx #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx
#x8b #x55 #x10 ; mov 0x10(%ebp),%edx #x8b #x55 #x10 ; mov 0x10(%ebp),%edx
#xb8 #x05 #x00 #x00 #x00 ; mov $0x5,%eax #xb8 #x05 #x00 #x00 #x00 ; mov $0x5,%eax
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
)) )))
(define (i386:access f g ta t d) (define i386:access
'( '(lambda (f g ta t d)
#x55 ; push %ebp (list
#x89 #xe5 ; mov %esp,%ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp
#x8b #x5d #x08 ; mov 0x8(%ebp),%ebx #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx
#x8b #x4d #x0c ; mov 0xc(%ebp),%ecx #x8b #x4d #x0c ; mov 0xc(%ebp),%ecx
#xb8 #x21 #x00 #x00 #x00 ; mov $0x21,%eax #xb8 #x21 #x00 #x00 #x00 ; mov $0x21,%eax
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
)) )))
(define (i386:brk f g ta t d) (define i386:brk
'( '(lambda (f g ta t d)
#x55 ; push %ebp (list
#x89 #xe5 ; mov %esp,%ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp
#x8b #x5d #x08 ; mov 0x8(%ebp),%ebx #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx
#xb8 #x2d #x00 #x00 #x00 ; mov $0x2d,%eax #xb8 #x2d #x00 #x00 #x00 ; mov $0x2d,%eax
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
)) )))
(define (i386:fsync f g ta t d) (define i386:fsync
'( '(lambda (f g ta t d)
#x55 ; push %ebp (list
#x89 #xe5 ; mov %esp,%ebp #x55 ; push %ebp
#x89 #xe5 ; mov %esp,%ebp
#x8b #x5d #x08 ; mov 0x8(%ebp),%ebx #x8b #x5d #x08 ; mov 0x8(%ebp),%ebx
#xb8 #x76 #x00 #x00 #x00 ; mov $0x76,%eax #xb8 #x76 #x00 #x00 #x00 ; mov $0x76,%eax
#xcd #x80 ; int $0x80 #xcd #x80 ; int $0x80
#xc9 ; leave #xc9 ; leave
#xc3 ; ret #xc3 ; ret
)) )))
(define (i386:_start) (define (i386:_start)
(string-append ".byte" (string-append ".byte"
" 0x89 0xe8" ; mov %ebp,%eax " 0x89 0xe8" ; mov %ebp,%eax
" 0x83 0xc0 0x08" ; add $0x8,%eax " 0x83 0xc0 0x08" ; add $0x8,%eax
" 0x50" ; push %eax " 0x50" ; push %eax

93
scripts/mescc.mes
View file

@ -37,17 +37,11 @@ exit $r
;;(mes-use-module (language c compiler)) ;;(mes-use-module (language c compiler))
;;Nyacc ;;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 guile))
(mes-use-module (mes getopt-long))
(mes-use-module (language c99 compiler)) (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") (format (current-error-port) "mescc.mes...\n")
@ -57,17 +51,76 @@ exit $r
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@")) (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
(define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@")) (define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
(define (main arguments) (define (parse-opts args)
(let* ((mfiles (cddr arguments)) (let* ((option-spec
(mfiles (if (or (null? mfiles) (not (equal? (car mfiles) "--"))) mfiles '((c (single-char #\c))
(cdr mfiles))) (D (single-char #\D) (value #t))
(mfile (if (null? mfiles) (string-append %docdir "examples/main.c") (help (single-char #\h))
(car mfiles)))) (I (single-char #\I) (value #t))
(format (current-error-port) "input: ~a\n" mfile) (o (single-char #\o) (value #t))
(with-input-from-file mfile (version (single-char #\V) (value #t))))
c99-input->elf))) (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)) (main (command-line))
() ()