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

mescc: Write object files in hex2 or hex3 format.

Browse source 
* stage0/elf32.hex2: New file.
* module/mes/hex2.mes: New file.
* module/mes/hex2.scm: New file.
* module/language/c99/compiler.mes: Eradicate object lamdas.
  (current-eval, dec-xhex, function:-object->text, object->elf,
  object->objects, merge-objects, alist-add): Remove.
* module/mes/elf.mes (object->elf): New function, move from compiler.mes.
* module/mes/elf.scm: Export it.
* guile/mescc.scm (parse-opts): Add -g.
  (main): Use it.
* scripts/mescc.mes: Likewise.
* scripts/mescc-guile.make (MESCC.scm, MESLD.scm): Add -g flag.
* scripts/mescc-mes.make (MESCC.mes, MESLD.mes): Likewise.
* scaffold/m.c: Add proper includes.
* scaffold/argv.c: New file.
* scaffold/hello.c: Simplify.
* scaffold/micro-mes.c: Add proper includes.
* scaffold/t.c: Add proper includes.
This commit is contained in:
Jan Nieuwenhuizen 2017-06-11 13:11:40 +02:00
parent 766cfeab9a
commit 1263d6e278
20 changed files with 687 additions and 472 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
guile/mescc.scm
View file

@ -36,6 +36,8 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
(define-module (mescc)
#:use-module (language c99 compiler)
#:use-module (mes elf)
#:use-module (mes hex2)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
@ -58,6 +60,7 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
'((c (single-char #\c))
(D (single-char #\D) (value #t))
(E (single-char #\E))
(g (single-char #\g))
(help (single-char #\h))
(I (single-char #\I) (value #t))
(o (single-char #\o) (value #t))
@ -72,10 +75,11 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
(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...
Usage: mescc.scm [OPTION]... FILE...
-c compile and assemble, but do not link
-D DEFINE define DEFINE
-E preprocess only; do not compile, assemble or link
-g add debug info [GDB, objdump] using hex3 format
-h, --help display this help and exit
-I DIR append DIR to include path
-o FILE write output to FILE
@ -84,10 +88,10 @@ Usage: mescc [OPTION]... FILE...
(exit (or (and usage? 2) 0)))
options)))
(define (object->info file)
(let* ((lst (with-input-from-file file read))
(module (resolve-module '(language c99 compiler))))
(eval lst module)))
(define (read-object file)
(let ((char (with-input-from-file file read-char)))
(if (eq? char #\#) (error "hex2 format not supported:" file)))
(with-input-from-file file read))
(define (main:ast->info file)
(let ((ast (with-input-from-file file read)))
@ -122,6 +126,7 @@ Usage: mescc [OPTION]... FILE...
(car files)))
(preprocess? (option-ref options 'E #f))
(compile? (option-ref options 'c #f))
(debug-info? (option-ref options 'g #f))
(asts (filter ast? files))
(objects (filter object? files))
(sources (filter (cut string-suffix? ".c" <>) files))
@ -131,7 +136,8 @@ Usage: mescc [OPTION]... FILE...
(else "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))))
(includes (reverse (filter-map (multi-opt 'I) options)))
(objects->hex (if debug-info? objects->hex3 objects->hex2)))
(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))
@ -139,16 +145,18 @@ Usage: mescc [OPTION]... FILE...
(lambda ()
(if (and (not compile?)
(not preprocess?)) (set-port-encoding! (current-output-port) "ISO-8859-1"))
(cond ((pair? objects) (let ((infos (map object->info objects)))
(if compile? (infos->object infos)
(infos->elf infos))))
((pair? asts) (let ((infos (map main:ast->info asts)))
(if compile? (infos->object infos)
(infos->elf infos))))
(cond ((pair? objects) (let ((objects (map read-object objects)))
(if compile? (objects->hex objects)
(objects->elf objects))))
((pair? asts) (let* ((infos (map main:ast->info asts))
(objects (map info->object infos)))
(if compile? (objects->hex objects)
(objects->elf objects))))
((pair? sources) (if preprocess? (map (source->ast defines includes) sources)
(let ((infos (map (source->info defines includes) sources)))
(if compile? (infos->object infos)
(infos->elf infos))))))))
(let* ((infos (map (source->info defines includes) sources))
(objects (map info->object infos)))
(if compile? (objects->hex objects)
(objects->elf objects))))))))
(if (and (not compile?)
(not preprocess?))
(chmod out #o755))))

4
make/mescc-guile.make
View file

@ -15,8 +15,8 @@ CLEAN+=$(O_FILES) $(OUT)/$(TARGET)
CLEAN+=$(OUT)/$(TARGET)
INCLUDES+=mlibc/include mlibc $(OUT)/$(DIR)
MESCC.scm:=guile/mescc.scm
MESLD.scm:=guile/mescc.scm
MESCC.scm:=guile/mescc.scm -g
MESLD.scm:=guile/mescc.scm -g
$(OUT)/$(TARGET): ld:=MESLD.scm
$(OUT)/$(TARGET): LD:=$(MESLD.scm)

4
make/mescc-mes.make
View file

@ -14,8 +14,8 @@ CLEAN+=$(O_FILES) $(OUT)/$(TARGET)
CLEAN+=$(OUT)/$(TARGET)
INCLUDES+=mlibc/include mlibc $(OUT)/$(DIR)
MESCC.mes:=scripts/mescc.mes
MESLD.mes:=scripts/mescc.mes
MESCC.mes:=scripts/mescc.mes -g
MESLD.mes:=scripts/mescc.mes -g
$(OUT)/$(TARGET): ld:=MESLD.mes
$(OUT)/$(TARGET): LD:=$(MESLD.mes)

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

@ -26,16 +26,16 @@
;;; Code:
(cond-expand
(guile-2
(set-port-encoding! (current-output-port) "ISO-8859-1"))
(guile-2)
(guile)
(mes
(mes-use-module (srfi srfi-26))
(mes-use-module (mes pmatch))
(mes-use-module (nyacc lang c99 parser))
(mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mes elf-util))
(mes-use-module (mes elf))
(mes-use-module (mes as-i386))
(mes-use-module (mes hex2))
(mes-use-module (mes optargs))))
(define (logf port string . rest)
@ -141,20 +141,18 @@
(define <constants> '<constants>)
(define <functions> '<functions>)
(define <globals> '<globals>)
(define <init> '<init>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
(define <break> '<break>)
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()) (break '()))
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (function #f) (text '()) (break '()))
(pmatch o
(<info> (list <info>
(cons <types> types)
(cons <constants> constants)
(cons <functions> functions)
(cons <globals> globals)
(cons <init> init)
(cons <locals> locals)
(cons <function> function)
(cons <text> text)
@ -176,10 +174,6 @@
(pmatch o
((<info> . ,alist) (assq-ref alist <globals>))))
(define (.init o)
(pmatch o
((<info> . ,alist) (assq-ref alist <init>))))
(define (.locals o)
(pmatch o
((<info> . ,alist) (assq-ref alist <locals>))))
@ -205,7 +199,6 @@
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(init (.init o))
(locals (.locals o))
(function (.function o))
(text (.text o))
@ -216,18 +209,15 @@
(constants constants)
(functions functions)
(globals globals)
(init init)
(locals locals)
(function function)
(text text)
(break break))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text #:break break))))))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text #:break break))))))
(define (push-global globals)
(lambda (o)
(list
`(lambda (f g ta t d)
(i386:push-global (+ (data-offset ,o g) d))))))
(list (i386:push-label-mem o))))
(define (push-local locals)
(lambda (o)
@ -235,9 +225,7 @@
(define (push-global-address globals)
(lambda (o)
(list
`(lambda (f g ta t d)
(i386:push-global-address (+ (data-offset ,o g) d))))))
(list (i386:push-label o))))
(define (push-local-address locals)
(lambda (o)
@ -273,7 +261,7 @@
(make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value)))
(define (ident->global name type pointer value)
(make-global name type pointer (int->bv32 value)))
(make-global name type pointer (if (pair? value) value (int->bv32 value))))
(define (make-local name type pointer id)
(cons name (list type pointer id)))
@ -298,13 +286,16 @@
(if constant
(wrap-as (append (i386:value->accu constant)
(i386:push-accu)))
(error "TODO:push-function: " o)))))))))
((push-global-address #f) `(address ,o))))))))))
(define (push-ident-address info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-address (.locals info)) local)
((push-global-address (.globals info)) o)))))
(let ((global (assoc-ref (.globals info) o)))
(if global
((push-global-address (.globals info)) o)
((push-global-address #f) `(address ,o))))))))
(define (push-ident-de-ref info)
(lambda (o)
@ -385,41 +376,25 @@
(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)))))
((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)))))))
((-1) (list (i386:label->accu o)))
((1) (list (i386:label-mem->accu o)))
((2) (list (i386:label->accu o)))
(else (list (i386:label-mem->accu o)))))
(if constant (wrap-as (i386:value->accu constant))
(list `(lambda (f g ta t d)
(i386:global->accu (+ ta (function-offset ,o f)))))))))))
(list (i386:label->accu `(address ,o)))))))))
(define (ident-address->accu info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o))
(global (assoc-ref (.globals info) o))
(constant (assoc-ref (.constants info) o)))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (= ptr 1) (type->size info type)
4)))
;;(stderr "ident->accu ~a => ~a\n" o ptr)
(if local (let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (= ptr 1) (type->size info type)
4)))
(wrap-as (i386:local-ptr->accu (local:id local))))
(if global
(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))))))))))
(if global (list (i386:label->accu o))
(list (i386:label->accu `(address ,o))))))))
(define (ident-address->base info)
(lambda (o)
@ -432,15 +407,8 @@
(size (if (= ptr 1) (type->size info type)
4)))
(wrap-as (i386:local-ptr->base (local:id local))))
(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)))))
(else (list `(lambda (f g ta t d)
(append (i386:value->base (+ (data-offset ,o g) d))))))))
(error "TODO ident-address->base" o))))))
(if global (list (i386:label->base o))
(list (i386:label->accu `(address ,o))))))))
(define (value->accu v)
(wrap-as (i386:value->accu v)))
@ -448,20 +416,15 @@
(define (accu->ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(let ((ptr (local:pointer local)))
(case ptr
(else (wrap-as (i386:accu->local (local:id local))))))
(if local (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 (i386:accu->label o)))))))
(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 (i386:base->label o))))))
(define (base->ident-address info)
(lambda (o)
@ -480,15 +443,13 @@
(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 (i386:value->label o 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 (i386:label-mem-add o n))))))
(define (ident-address-add info)
(lambda (o n)
@ -497,11 +458,10 @@
(i386:local->accu (local:id local))
(i386:accu-mem-add n)
(i386:pop-accu)))
(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:pop-accu))))))))
(list (wrap-as (append (i386:push-accu)
(i386:label->accu o)
(i386:accu-mem-add n)
(i386:pop-accu))))))))
;; FIXME: see ident->accu
(define (ident->base info)
@ -522,16 +482,12 @@
(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 (i386:label->base o)))
((2) (list (i386:label->base o)))
(else (list (i386:label-mem->base o)))))
(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 (i386:label->base `(address ,o)))))))))))
(define (expr->accu info)
(lambda (o)
@ -549,12 +505,10 @@
((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) g) d)))))))
(append-text info (list (i386:label->accu (add-s:-prefix string))))))
((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)) g) d))))))
(append-text info (list (i386:label->accu (add-s:-prefix (apply string-append strings))))))
((p-expr (fixed ,value))
(append-text info (value->accu (cstring->number value))))
@ -685,15 +639,16 @@
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list)))
(if (and (not (assoc-ref locals name))
(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))))
(if (not (assoc-ref locals name))
(begin
(if (and (not (assoc name (.functions info)))
(not (assoc name globals)))
(stderr "warning: undeclared function: ~a\n" name))
(append-text args-info (list (i386:call-label name 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 (i386:call-accu n)))))))))
((fctn-call ,function (expr-list . ,expr-list))
(let* ((text-length (length text))
@ -704,8 +659,7 @@
(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 (i386:call-accu n))))))
((cond-expr . ,cond-expr)
((ast->info info) `(expr-stmt ,o)))
@ -838,8 +792,7 @@
(ptr (ident->pointer info array))
(size (if (> ptr 1) 4 1)))
(append-text info (append (wrap-as (i386:accu->base))
((base->ident-address info) array)
(i386:base->accu)))))
((base->ident-address info) array)))))
((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu* info) a))
@ -853,9 +806,9 @@
((array-ref ,index (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(size (type->size info type))
(info (append-text info (wrap-as (append (i386:push-accu)))))
(info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu* info) a))
(info (append-text info (wrap-as (append (i386:pop-base))))))
(info (append-text info (wrap-as (i386:pop-base)))))
(append-text info
(append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
(if (<= size 4) (wrap-as (i386:base->accu-address))
@ -888,8 +841,8 @@
(define (append-text info text)
(clone info #:text (append (.text info) text)))
(define (wrap-as o)
(list `(lambda (f g ta t d) ,(cons 'list o))))
(define (wrap-as o . annotation)
`(,@annotation ,o))
(define (expr->accu* info)
(lambda (o)
@ -917,7 +870,7 @@
(let* ((type (ident->type info array))
(offset (field-offset info type field))
(info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
(append-text info (wrap-as (append (i386:accu+value offset))))))
(append-text info (wrap-as (i386:accu+value offset)))))
((d-sel (ident ,field) (p-expr (ident ,name)))
(let* ((type (ident->type info name))
@ -1366,10 +1319,12 @@
((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
(append-text info (wrap-as (asm->hex arg0))))
(let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
(append-text info (wrap-as (i386:accu-zero?))))))
(let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
(info (append-text info (wrap-as `(#:comment ,source)))))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
(append-text info (wrap-as (asm->hex arg0))))
(let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
(append-text info (wrap-as (i386:accu-zero?)))))))
((if ,test ,body)
(let* ((text-length (length text))
@ -1514,7 +1469,9 @@
#:locals locals)))
((while ,test ,body)
(let* ((skip-info (lambda (body-length test-length)
(let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (ellipsis))))))
;;(source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (compd-stmt (block-item-list)))))))
(skip-info (lambda (body-length test-length)
(clone info
#:text (append text (wrap-as (i386:Xjump body-length)))
#:break (cons (+ (length (object->list text)) body-length test-length
@ -1542,6 +1499,7 @@
(clone info #:text
(append
(wrap-as `(#:comment ,source))
(.text body-info)
test-text
jump-text)
@ -1571,15 +1529,13 @@
#:globals (.globals body-info))))
((labeled-stmt (ident ,label) ,statement)
(let ((info (append-text info (list label))))
(let ((info (append-text info `((#:label ,label)))))
((ast->info info) statement)))
((goto (ident ,label))
(let* ((jump (lambda (n) (i386:XXjump n)))
(offset (+ (length (jump 0)) (length (object->list text)))))
(append-text info (append
(list `(lambda (f g ta t d)
(i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
(append-text info (list (i386:jump-label `(label ,label))))))
((return ,expr)
(let ((info ((expr->accu info) expr)))
@ -1641,26 +1597,14 @@
(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)
(append
(i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
(list (i386:label->accu (add-s:-prefix string)))
((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)))
(clone info #:init
(append
(.init info)
(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)))))))))))
(global (make-global name type 1 (initzer->data `(initzer (p-expr (string ,string))))))
(globals (append globals (list global))))
(clone info #:globals globals))))
;; char *p;
((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
@ -1712,9 +1656,6 @@
(let ((globals (append globals (list (ident->global name type 2 0)))))
(clone info #:globals globals))))
;; char **p = 0;
;;((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (fixed ,value)))))))
;; char **p = g_environment;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
(if (.function info)
@ -1723,18 +1664,10 @@
(append-text info (append
((ident->accu info) b)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 2 0))))
(value (assoc-ref constants b)))
(clone info
#:globals globals
#:init (append (.init info)
(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)))))))))))
(let* ((value (assoc-ref constants b))
(global (ident->global name type 2 (initzer->data `(p-expr (fixed ,value)))))
(globals (append globals (list global))))
(clone info #:globals globals))))
;; struct foo bar[2];
;; char arena[20000];
@ -1843,9 +1776,8 @@
(append text
(.text accu)
((accu->ident info) name)
(list `(lambda (f g ta t d)
(append (i386:value->base ta)
(i386:accu+base)))))
(wrap-as (append (i386:label->base '(address "_start"))
(i386:accu+base))))
#:locals locals)))
;; char *p = (char*)g_cells;
@ -1855,22 +1787,8 @@
(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)))))
(clone info
#:globals globals
#:init (append (.init info)
(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)))))))))))
(let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
(clone info #:globals globals))))
;; 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))))))
@ -1880,18 +1798,8 @@
(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)))))
(clone info
#:globals globals
#:init (append (.init info)
(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))))))))))))
(let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
(clone info #:globals globals)))))
;; enum foo { };
((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
@ -2008,22 +1916,10 @@
(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)))
(clone info #:init
(append
(.init info)
(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))))))))))))
(let* (;;(global (make-global name type 2 (string->list (make-string size #\nul))))
(global (make-global name type 2 (append-map initzer->data initzers)))
(globals (append globals entries (list global))))
(clone info #:globals globals)))))
;;
;; struct f = {...};
@ -2053,24 +1949,9 @@
(.text ((expr->accu empty) initzer))
(wrap-as (i386:accu->base-address+n offset)))))))))
(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)))
(info (clone info #:globals globals)))
(let loop ((fields fields) (initzers initzers) (info info))
(if (null? fields) info
(let ((offset (field-offset info type (caar fields)))
(initzer (car initzers)))
(loop (cdr fields) (cdr initzers)
(clone info #:init
(append
(.init info)
(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 (car fields))))))))))))))))))
(global (make-global name type 2 (append-map initzer->data initzers)))
(globals (append globals (list global))))
(clone info #:globals globals)))))
;;char cc = g_cells[c].cdr; ==> generic?
@ -2083,18 +1964,9 @@
(clone info #:text
(append (.text ((expr->accu info) initzer))
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0)))))
(clone info
#:globals globals
#:init (append (.init info)
(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))))))))))))
(let* ((global (make-global name type 2 (initzer->data initzer)))
(globals (append globals (list global))))
(clone info #:globals globals)))))
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
(declare name))
@ -2264,14 +2136,12 @@
`(initzer (p-expr (fixed ,(number->string value))))))
(_ o))))
(define (initzer->data f g ta t d o)
(define (initzer->data 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 f))))
((initzer (p-expr (string ,string)))
(int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f))
((initzer (p-expr (string ,string))) `(,(add-s:-prefix string) #f #f #f))
(_ (error "initzer->data: unsupported: " o))))
(define (.formals o)
@ -2345,46 +2215,8 @@
(if (null? elements) info
(loop (cdr elements) ((ast->info info) (car elements)))))))
(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"))
(apply append (filter (lambda (x) (and (pair? x) (not (member (car x) '(#:comment #:label))))) object)))
(define* (c99-input->info #:key (defines '()) (includes '()))
(lambda ()
@ -2396,63 +2228,15 @@
(info (clone info #:text '() #:locals '())))
info)))
(define (write-any x)
(write-char (cond ((char? x) x)
((and (number? x) (< (+ x 256) 0))
(format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
((procedure? x)
(stderr "write-any: proc: ~a\n" x)
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
(error "procedure: write-any:" x))
(else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
(define (info->elf info)
(display "dumping elf\n" (current-error-port))
(for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init 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* (info->object o)
`((functions . ,(.functions o))
(globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
(define* (c99-ast->info ast)
((ast->info (make <info> #:types i386:type-alist)) ast))
(define* (c99-input->elf #:key (defines '()) (includes '()))
((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
((compose object->elf info->object (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 (car f) b-keys)))) a))
(a-keys (map car a)))
(append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
((compose write-hex3 info->object (c99-input->info #:defines defines #:includes includes))))

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

@ -28,19 +28,18 @@
#:use-module (system base pmatch)
#:use-module (ice-9 optargs)
#:use-module (ice-9 pretty-print)
#:use-module (mes elf)
#:use-module (mes elf-util)
#:use-module (mes elf)
#:use-module (mes as-i386)
#:use-module (mes hex2)
#:use-module (nyacc lang c99 parser)
#:use-module (nyacc lang c99 pprint)
#:export (c99-ast->info
c99-input->ast
c99-input->elf
c99-input->info
c99-input->object
infos->object
info->elf
infos->elf
object->elf))
info->object))
(cond-expand
(guile-2)

71
module/mes/as-i386.mes
View file

@ -28,7 +28,7 @@
(guile-2)
(guile)
(mes
(mes-use-module (mes elf))))
(mes-use-module (mes elf-util))))
(define (i386:function-preamble)
'(#x55 ; push %ebp
@ -40,13 +40,11 @@
(define (i386:function-locals)
'(#x83 #xec #x40)) ; sub $0x10,%esp -- 16 local vars
(define (i386:push-global-address o)
(or o (error "invalid value: push-global-address: " o))
`(#x68 ,@(int->bv32 o))) ; push $0x<o>
(define (i386:push-label label)
`(#x68 ,label #f #f #F)) ; push $0x<o>
(define (i386:push-global o)
(or o (error "invalid value: push-global: " o))
`(#xa1 ,@(int->bv32 o) ; mov 0x804a000,%eax
(define (i386:push-label-mem label)
`(#xa1 ,label #f #f #f ; mov 0x804a000,%eax
#x50)) ; push %eax
(define (i386:push-local n)
@ -118,18 +116,8 @@
(or n (error "invalid value: base->local: " n))
`(#x89 #x55 ,(- 0 (* 4 n)))) ; mov %edx,-<0xn>(%ebp)
(define (i386:base->global n)
(or n (error "invalid value: base->global: " n))
`(#x89 #x15 ,@(int->bv32 n))) ; mov %edx,0x0
(define (i386:accu->global n)
(or n (error "invalid value: accu->global: " n))
`(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0
(define (i386:accu->global-address n)
(or n (error "invalid value: accu->global-address: " n))
`(#x8b #x15 ,@(int->bv32 n) ; mov 0x<n>,%edx
#x89 #x02 )) ; mov %eax,(%edx)
(define (i386:accu->label label)
`(#xa3 ,label #f #f #f))
(define (i386:accu-zero?)
'(#x85 #xc0)) ; cmpl %eax,%eax
@ -225,17 +213,20 @@
`(#x89 #xea ; mov %ebp,%edx
#x83 #xc2 ,(- 0 (* 4 n)))) ; add $0x<n>,%edx
(define (i386:global->base n)
(or n (error "invalid value: global->base: " n))
`(#xba ,@(int->bv32 n))) ; mov $<n>,%edx
(define (i386:label->accu label)
`(#xb8 ,label #f #f #f)) ; mov $<>,%eax
(define (i386:global-address->accu n)
(or n (error "invalid value: global-address->accu: " n))
`(#xa1 ,@(int->bv32 n))) ; mov 0x<n>,%eax
(define (i386:label->base label)
`(#xba ,label #f #f #f)) ; mov $<n>,%edx
(define (i386:global-address->base n)
(or n (error "invalid value: global-address->base: " n))
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0x<n>,%edx
(define (i386:label-mem->accu label)
`(#xa1 ,label #f #f #f)) ; mov 0x<n>,%eax
(define (i386:label-mem->base label)
`(#x8b #x15 ,label #f #f #f)) ; mov 0x<n>,%edx
(define (i386:label-mem-add label v)
`(#x83 #x05 ,label #f #f #f ,v)) ; addl $<v>,0x<n>
(define (i386:byte-base-mem->accu)
'(#x01 #xd0 ; add %edx,%eax
@ -304,17 +295,9 @@
(define (i386:accu-mem-add v)
`(#x83 #x00 ,v)) ; addl $<v>,(%eax)
(define (i386:global-add n v)
(or n (error "invalid value: i386:global-add: " n))
`(#x83 #x05 ,@(int->bv32 n) ,v)) ; addl $<v>,0x<n>
(define (i386:global->accu o)
(or o (error "invalid value: i386:global->accu: " o))
`(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax
(define (i386:value->global n v)
(or n (error "invalid value: value->global: " n))
`(#xc7 #x05 ,@(int->bv32 n) ; movl $<v>,(<n>)
(define (i386:value->label label v)
(or v (error "invalid value: value->label: " v))
`(#xc7 #x05 ,label #f #f #f ; movl $<v>,(<n>)
,@(int->bv32 v)))
(define (i386:value->local n v)
@ -326,12 +309,11 @@
(or n (error "invalid value: local-test: " n))
`(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp)
(define (i386:call f g ta t d address n)
(or address (error "invalid value: i386:call: " address))
`(#xe8 ,@(int->bv32 (- address 5)) ; call relative $00
(define (i386:call-label label n)
`(#xe8 ,label #f #f #f ; call relative $00
#x83 #xc4 ,(* n 4))) ; add $00,%esp
(define (i386:call-accu f g ta t d n)
(define (i386:call-accu n)
`(,@(i386:push-accu)
,@(i386:pop-accu)
#xff #xd0 ; call *%eax
@ -364,6 +346,9 @@
(or n (error "invalid value: i386:XXjump: n: " n))
`(#xe9 ,@(int->bv32 n))) ; jmp . + <n>
(define (i386:jump-label label)
`(#xe9 ,label #f #f #f)) ; jmp . + <n>
(define (i386:Xjump-nz n)
(or n (error "invalid value: i386:Xjump-nz: n: " n))
`(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n>

27
module/mes/as-i386.scm
View file

@ -25,15 +25,14 @@
;;; Code:
(define-module (mes as-i386)
#:use-module (mes elf)
#:use-module (mes elf-util)
#:export (
i386:accu-not
i386:accu-cmp-value
i386:accu->base
i386:accu->base-address
i386:accu->base-address+n
i386:accu->global
i386:accu->global-address
i386:accu->label
i386:accu->local
i386:accu-non-zero?
i386:accu-test
@ -55,7 +54,7 @@
i386:base->accu
i386:base->accu-address
i386:byte-accu->base-address
i386:base->global
i386:base->label
i386:base->local
i386:base-mem->accu
i386:byte-base-sub
@ -70,18 +69,18 @@
i386:byte-mem->base
i386:byte-test-base
i386:byte-sub-base
i386:call
i386:call-accu
i386:call-label
i386:formal
i386:function-locals
i386:function-preamble
i386:global-add
i386:global->accu
i386:global->base
i386:global-address->accu
i386:global-address->base
i386:jump
i386:label-mem-add
i386:label->accu
i386:label->base
i386:label-mem->accu
i386:label-mem->base
i386:jump
i386:jump-label
i386:jump-byte-nz
i386:jump-byte-z
i386:jump-c
@ -106,8 +105,8 @@
i386:push-accu
i386:pop-base
i386:push-base
i386:push-global
i386:push-global-address
i386:push-label
i386:push-label-mem
i386:push-local
i386:push-byte-local-de-ref
i386:push-byte-local-de-de-ref
@ -121,7 +120,7 @@
i386:value->accu
i386:value->accu-address
i386:value->accu-address+n
i386:value->global
i386:value->label
i386:value->local
i386:value->base
i386:xor-accu

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

@ -29,8 +29,20 @@
(guile)
(guile-2)
(mes
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-1))))
(define (int->bv32 value)
(let ((bv (make-bytevector 4)))
(bytevector-u32-native-set! bv 0 value)
bv))
(define (int->bv16 value)
(let ((bv (make-bytevector 2)))
(bytevector-u16-native-set! bv 0 value)
bv))
(define (make-global name type pointer value)
(cons name (list type pointer value)))
@ -43,28 +55,64 @@
(define (dec->hex o)
(cond ((number? o) (number->string o 16))
((char? o) (number->string (char->integer o) 16))))
((char? o) (number->string (char->integer o) 16))
(else (format #f "~s" o))))
(define (functions->lambdas functions)
(append-map (lambda (f) (or (cdr f) '())) functions))
(define (lambda/label->list f g ta t d)
(lambda (l/l)
(if (not (procedure? l/l)) '() (l/l f g ta t d))))
(define (functions->lines functions)
(filter (lambda (x) (not (and (pair? x) (pair? (car x)) (member (caar x) '(#:comment #:label))))) (append-map cdr functions))
;;(append-map cdr functions)
)
(define (text->list o)
(append-map (lambda/label->list '() '() 0 0 0) o))
(append-map cdr o))
(define functions->text
(let ((cache '()))
(lambda (functions globals ta t d)
(or (assoc-ref cache (cons ta (map car functions)))
(let ((text (let loop ((lambdas/labels (functions->lambdas functions)) (text '()))
(if (null? lambdas/labels) text
(loop (cdr lambdas/labels)
(append text ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels))))))))
(set! cache (assoc-set! cache (cons ta (map car functions)) text))
text)))))
(let ((text (or (assoc-ref cache (cons ta (map car functions)))
(let ((text (apply append (functions->lines functions))))
(set! cache (assoc-set! cache (cons ta (map car functions)) text))
text))))
(if (= ta 0) text
(let loop ((f functions))
(if (null? f) '()
(append ((function->text functions globals ta t d) (car f))
(loop (cdr f))))))))))
(define (function->text functions globals ta t d)
(lambda (o)
(let ((text (apply append (cdr o)))
(offset (function-offset (car o) functions)))
(let loop ((text text) (off offset))
(if (null? text) '()
(let ((label (car text)))
(if (number? label) (cons label (loop (cdr text) (1+ off)))
(if (and (pair? label) (member (car label) '(#:comment #:label))) ;;(cons #x90 (loop (cdr text) (1+ off)))
(loop (cdr text) off)
(let* ((prefix (if (and (pair? (cdr text))
(pair? (cddr text))
(boolean? (caddr text))) 4
2))
;;(foo (format (current-error-port) "LABEL=~s\n" label))
;; FiXME: address vs relative address
(address? (and (pair? label) (member (car label) '(address))))
(label (if address? (cadr label) label))
(function-address (function-offset label functions))
(data-address (data-offset label globals))
(label-address (label-offset (car o) (and (pair? label)
`((#:label ,(cadr label)))) functions))
;; (foo (format (current-error-port) " address?=~s\n" address?))
;; (foo (format (current-error-port) " d=~s\n" data-address))
;; (foo (format (current-error-port) " f=~s\n" function-address))
;; (foo (format (current-error-port) " l=~s\n" label-address))
(address (or (and=> data-address (lambda (a) (+ a d)))
(if address?
(and=> function-address (lambda (a) (+ a ta)))
(and=> function-address (lambda (a) (- a off prefix))))
(and=> label-address (lambda (a) (- a (- off offset) prefix)))
(error "unresolved label: " label))))
(append ((if (= prefix 2) int->bv16 int->bv32) address)
(loop (list-tail text prefix) (+ off prefix))))))))))))
(define (function-prefix name functions)
;; FIXME
@ -85,7 +133,7 @@
(if (null? (cdr prefix)) 0
(function-offset (caar prefix) functions)))))))
(if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset)))
(or offset 0))))))
offset)))))
(define label-offset
(let ((cache '()))
@ -95,26 +143,45 @@
(if (not prefix) 0
(let* ((function-entry (car prefix))
(offset (let loop ((text (cdr function-entry)))
(if (or (equal? (car text) label) (null? text)) 0
(let* ((l/l (car text))
(t ((lambda/label->list '() '() 0 0 0) l/l))
(n (length t)))
;; FIXME: unresolved label
;;(if (null? text) (error "unresolved label:"))
(if (or (null? text) (equal? (car text) label)) 0
(let* ((t (car text))
(n (if (and (pair? (car t))
(member (caar t) '(#:label #:comment))) 0 (length t))))
(+ (loop (cdr text)) n))))))
(when (> offset 0)
(set! cache (assoc-set! cache (cons function label) offset)))
offset)))))))
(define (globals->data globals)
(append-map (compose global:value cdr) globals))
(define (globals->data functions globals t d)
(let loop ((text (append-map cdr globals)))
(if (null? text) '()
(let ((label (car text)))
(if (or (char? label) (number? label)) (cons label (loop (cdr text)))
(let* ((prefix (if (and (pair? (cdr text))
(pair? (cddr text))
(boolean? (caddr text))) 4
2))
(function-address (function-offset label functions))
(data-address (data-offset label globals))
(address (or (and=> data-address (lambda (a) (+ a d)))
(and=> function-address (lambda (a) (+ a t)))
(error "unresolved label: " label))))
(append ((if (= prefix 2) int->bv16 int->bv32) address)
(loop (list-tail text prefix)))))))))
(define (simple-globals->data globals)
(append-map cdr globals))
(define data-offset
(let ((cache '()))
(lambda (name globals)
(or ;;(assoc-ref cache name)
(let* ((prefix (member name (reverse globals)
(lambda (a b)
(equal? (car b) name)))))
(if (not prefix) 0
(let ((offset (length (globals->data (cdr prefix)))))
(set! cache (assoc-set! cache name offset))
offset)))))))
(or (assoc-ref cache name)
(let ((prefix (member name (reverse globals)
(lambda (a b)
(equal? (car b) name)))))
(and prefix
(let ((offset (length (simple-globals->data (cdr prefix)))))
(set! cache (assoc-set! cache name offset))
offset)))))))

3
module/mes/elf-util.scm
View file

@ -24,11 +24,14 @@
(define-module (mes elf-util)
#:use-module (srfi srfi-1)
#:use-module (mes bytevectors)
#:export (data-offset
dec->hex
add-s:-prefix
drop-s:-prefix
function-offset
int->bv16
int->bv32
label-offset
functions->lambdas
functions->text

50
module/mes/elf.mes
View file

@ -1,4 +1,4 @@
;;; -*-scheme-*-
<;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
@ -28,19 +28,8 @@
(guile)
(mes
(mes-use-module (srfi srfi-1))
(mes-use-module (mes bytevectors))
(mes-use-module (mes elf-util))))
(define (int->bv32 value)
(let ((bv (make-bytevector 4)))
(bytevector-u32-native-set! bv 0 value)
bv))
(define (int->bv16 value)
(let ((bv (make-bytevector 2)))
(bytevector-u16-native-set! bv 0 value)
bv))
(define elf32-addr int->bv32)
(define elf32-half int->bv16)
(define elf32-off int->bv32)
@ -213,7 +202,7 @@
(define text-address (+ text-offset vaddress))
(define data-length
(length (globals->data globals)))
(length (globals->data functions globals 0 0)))
(define comment-length
(length comment))
@ -241,10 +230,11 @@
(define SHF-STRINGS #x20)
(let* ((text (functions->text functions globals text-address 0 data-address))
(raw-data (globals->data globals))
(data (let loop ((data raw-data) (init init))
(if (null? init) data
(loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
(raw-data (globals->data functions globals text-address data-address))
;; (data (let loop ((data raw-data) (init init))
;; (if (null? init) data
;; (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
(data raw-data)
(entry (+ text-offset (function-offset "_start" functions)))
(sym (sym functions globals))
(str (str functions)))
@ -291,3 +281,29 @@
sym
str
(section-headers))))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (write-any x)
(write-char
(cond ((char? x) x)
((and (number? x) (< (+ x 256) 0))
(format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
((procedure? x)
(stderr "write-any: proc: ~a\n" x)
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
(error "procedure: write-any:" x))
(else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
(define (object->elf object)
(display "dumping elf\n" (current-error-port))
(for-each
write-any
(make-elf (filter cdr (assoc-ref object 'functions)) (assoc-ref object 'globals) (assoc-ref object 'inits))))

8
module/mes/elf.scm
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -24,11 +24,9 @@
(define-module (mes elf)
#:use-module (srfi srfi-1)
#:use-module (mes bytevectors)
#:use-module (mes elf-util)
#:export (int->bv16
int->bv32
make-elf))
#:export (make-elf
object->elf))
(cond-expand
(guile-2)

194
module/mes/hex2.mes Normal file
View file

@ -0,0 +1,194 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; hex2.mes produces stage0' hex2 object format
;;; Code:
(cond-expand
(guile)
(mes
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes elf-util))
(mes-use-module (mes elf))
(mes-use-module (mes optargs))))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (dec->xhex o)
(if (number? o) (string-append "#x" (dec->hex o))
(format #f "~s" o)))
(define (write-hex3 o)
(define (write-line o)
(cond ((null? o))
((not (pair? o))
(display (dec->xhex o)))
((string? (car o))
(format #t ";; ~a\n" (car o))
(display (string-join (map dec->xhex (cdr o)) " ")))
((number? (car o))
(display (string-join (map dec->xhex o) " ")))
((member (car o) '(#:comment #:label))
(write o))
((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
(write (car o)))
(else (error "write-line LINE:" o))))
(define (write-function o)
(stderr "function: ~s\n" (car o))
(format #t "\n(~s " (car o))
(if (pair? (cadr o)) (for-each
(lambda (x) (display "\n (") (write-line x) (display ")"))
(filter pair? (cdr o)))
(write-line o))
(display ")"))
(define (write-global o)
(stderr "global: ~s\n" (car o))
(format #t "\n(~s "(car o))
(display (string-join (map dec->xhex (cdr o)) " "))
(display ")"))
(define (write-init o)
(stderr "init: ~s\n" o)
(format #t "\n (~s "(car o))
(display (string-join (map dec->xhex (global:value (cdr o))) " "))
(display ")"))
(stderr "object:\n")
(display ";;; hex3: hex2 in sexps with annotated labels\n")
(display "((functions ")
(for-each write-function (filter cdr (assoc-ref o 'functions)))
(display ")\n")
(display "(globals ")
(for-each write-global (assoc-ref o 'globals))
(display "))\n"))
(define (objects->hex2 objects)
((compose write-hex2 merge-objects) objects))
(define (objects->hex3 objects)
((compose write-hex3 merge-objects) objects))
(define (objects->elf objects)
((compose object->elf merge-objects) objects))
(define (merge-objects objects)
(let loop ((objects (cdr objects)) (object (car objects)))
(if (null? objects) object
(loop (cdr objects)
`((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
(globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
(define (alist-add a b)
(let* ((b-keys (map car b))
(a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
(a-keys (map car a)))
(append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
(define (write-hex2 o)
(let* ((functions (assoc-ref o 'functions))
(function-names (map car functions))
(globals (assoc-ref o 'globals))
(global-names (map car globals))
(strings (filter (cut string-prefix? "s:" <>) global-names)))
(define (string->label o)
(format #f "string_~a" (list-index (lambda (s) (equal? s o)) strings)))
(define (dec->hex o)
(cond ((number? o) (string-append (if (and (>= o 0) (< o 16)) "0" "")
(number->string
(if (>= o 0) o (+ o #x100))
16)))
((char? o) (dec->hex (char->integer o)))
((and (string? o) (string-prefix? "s:" o))
(format #f "&~a" (string->label o)))
((string? o) (format #f "~a" o))
(else (format #f "~a" o))))
(define (write-line o)
(newline)
(cond ((not (pair? o))
(display (dec->hex o)))
((number? (car o))
;;(display (string-join (map dec->hex (filter identity o)) " "))
(let ((text (let loop ((text o))
(if (null? text) '()
(let ((label (car text)))
(if (number? label) (cons label (loop (cdr text)))
(if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text))
(let* ((prefix (if (and (pair? (cdr text))
(pair? (cddr text))
(boolean? (caddr text))) 4
2))
(address? (and (pair? label) (member (car label) '(address))))
(label (if address? (cadr label) label))
(function? (member label function-names))
(string-label (string->label label))
(string? (not (equal? string-label "string_#f")))
(global? (member label global-names))
(label? (and (pair? label) (eq? (car label) #:label))))
(cons (cond
((eq? prefix 1) (format #f "!~a" label))
((eq? prefix 2) (format #f "@~a" label))
(label? (format #f "%label_~a" label))
(function? (format #f "%~a" label))
(string? (format #f "&~a" string-label))
(global? (format #f "&~a" label))
(else (format #f "%~a" label)))
(loop (list-tail text prefix)))))))))))
(display (string-join (map dec->hex text) " "))))
((member (car o) '(#:comment))
(format #t "# ~a" (cadr o)))
((eq? (car o) #:label)
(format #t ":~a\n" (cadr o)))
((and (pair? (car o)) (eq? (caar o) #:label))
(format #t ":~a\n" (cadar o)))
((and (pair? (car o)) (member (caar o) '(#:comment)))
(format #t "# ~a" (cadar o)))
((and (pair? (car o)) (member (caar o) '(#:comment #:label)))
(write (car o)))
(else (error "write-line LINE:" o))))
(define (write-function o)
(format #t "\n\n:~a" (car o))
(if (pair? (cadr o)) (for-each write-line (cdr o))
(write-line (cdr o))))
(define (write-global o)
(let ((label (if (not (string-prefix? "s:" (car o))) (car o)
(string->label (car o)))))
(format #t "\n:~a\n" label)
(display (string-join (map dec->hex (cdr o)) " "))
(newline)))
(display "### stage0's hex2 format for x86\n")
(display "### !<label> 1 byte relative\n")
(display "### $<label> 2 byte address\n")
(display "### @<label> 2 byte relative\n")
(display "### &<label> 4 byte address\n")
(display "### %<label> 4 byte relative\n")
(display "### label_<label> function-local\n")
(display "### string_<index> string #<index>\n")
(display "\n##.text")
(for-each write-function (filter cdr functions))
(display "\n\n##.data\n")
(for-each write-global globals)))

42
module/mes/hex2.scm Normal file
View file

@ -0,0 +1,42 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (mes hex2)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (mes elf-util)
#:use-module (mes elf)
#:export (objects->hex2
objects->hex3
objects->elf
write-hex2
write-hex3))
(cond-expand
(guile-2)
(guile
(use-modules (ice-9 syncase)))
(mes))
(include-from-path "mes/hex2.mes")

38
scaffold/argv.c Normal file
View file

@ -0,0 +1,38 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
* Mes is free software; you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 3 of the License, or (at
* your option) any later version.
*
* Mes is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#include <stdio.h>
int
main (int argc, char *argv[])
{
eputs ("Hi Mes!\n");
#if __MESC_MES__
eputs ("MESC.MES\n");
#else
puts ("MESC.GUILE\n");
#endif
if (argc > 1 && !strcmp (argv[1], "--help"))
{
eputs ("argc > 1 && --help\n");
return argc;
}
return 42;
}

10
scaffold/hello.c
View file

@ -18,17 +18,11 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#include <mlibc.h>
#include <stdio.h>
int
main (int argc, char *argv[])
{
puts ("Hi Mes!\n");
#if __MESC_MES__
puts ("MESC.MES\n");
#else
puts ("MESC.GUILE\n");
#endif
if (argc > 1 && !strcmp (argv[1], "--help")) {puts ("argc > 1 && --help\n"); return argc;}
eputs ("Hello, Mescc!\n");
return 42;
}

2
scaffold/m.c
View file

@ -18,7 +18,9 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#include <fcntl.h>
#include <stdio.h>
#include <stdlib.h>
int
main (int argc, char *argv[])

2
scaffold/micro-mes.c
View file

@ -22,7 +22,7 @@
#error "POSIX not supported"
#endif
#include <mlibc.h>
#include <stdio.h>
typedef int SCM;

2
scaffold/t.c
View file

@ -21,6 +21,8 @@
#include <mlibc.h>
#include <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
struct scm {
int type;

37
scripts/mescc.mes
View file

@ -41,6 +41,8 @@ exit $r
(mes-use-module (mes getopt-long))
(mes-use-module (mes pretty-print))
(mes-use-module (language c99 compiler))
(mes-use-module (mes elf))
(mes-use-module (mes hex2))
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
@ -57,6 +59,7 @@ exit $r
'((c (single-char #\c))
(D (single-char #\D) (value #t))
(E (single-char #\E))
(g (single-char #\g))
(help (single-char #\h))
(I (single-char #\I) (value #t))
(o (single-char #\o) (value #t))
@ -71,10 +74,11 @@ exit $r
(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...
Usage: mescc.mes [OPTION]... FILE...
-c compile and assemble, but do not link
-D DEFINE define DEFINE
-E preprocess only; do not compile, assemble or link
-g add debug info [GDB, objdump] using hex3 format
-h, --help display this help and exit
-I DIR append DIR to include path
-o FILE write output to FILE
@ -83,9 +87,10 @@ Usage: mescc [OPTION]... FILE...
(exit (or (and usage? 2) 0)))
options)))
(define (object->info file)
(let* ((lst (with-input-from-file file read)))
(primitive-eval lst)))
(define (read-object file)
(let ((char (with-input-from-file file read-char)))
(if (eq? char #\#) (error "hex2 format not supported:" file)))
(with-input-from-file file read))
(define (main:ast->info file)
(let ((ast (with-input-from-file file read)))
@ -121,6 +126,7 @@ Usage: mescc [OPTION]... FILE...
(car files)))
(preprocess? (option-ref options 'E #f))
(compile? (option-ref options 'c #f))
(debug-info? (option-ref options 'g #f))
(asts (filter ast? files))
(objects (filter object? files))
(sources (filter (cut string-suffix? ".c" <>) files))
@ -130,23 +136,26 @@ Usage: mescc [OPTION]... FILE...
(else "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))))
(includes (reverse (filter-map (multi-opt 'I) options)))
(objects->hex (if debug-info? objects->hex3 objects->hex2)))
(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))
(with-output-to-port (open-output-file out (if (and (not compile?)
(not preprocess?)) S_IRWXU))
(lambda ()
(cond ((pair? objects) (let ((infos (map object->info objects)))
(if compile? (infos->object infos)
(infos->elf infos))))
((pair? asts) (let ((infos (map main:ast->info asts)))
(if compile? (infos->object infos)
(infos->elf infos))))
(cond ((pair? objects) (let ((objects (map read-object objects)))
(if compile? (objects->hex objects)
(objects->elf objects))))
((pair? asts) (let* ((infos (map main:ast->info asts))
(objects (map info->object infos)))
(if compile? (objects->hex objects)
(objects->elf objects))))
((pair? sources) (if preprocess? (map (source->ast defines includes) sources)
(let ((infos (map (source->info defines includes) sources)))
(if compile? (infos->object infos)
(infos->elf infos))))))))))
(let* ((infos (map (source->info defines includes) sources))
(objects (map info->object infos)))
(if compile? (objects->hex objects)
(objects->elf objects))))))))))
(main (command-line))
()

75
stage0/elf32.hex2 Normal file
View file

@ -0,0 +1,75 @@
### Copyright (C) 2016 Jeremiah Orians
### Copyright (C) 2017 Jan Nieuwenhuizen <janneke@gnu.org>
### This file is part of stage0.
###
### stage0 is free software: you an redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation, either version 3 of the License, or
### (at your option) any later version.
###
### stage0 is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
### GNU General Public License for more details.
###
### You should have received a copy of the GNU General Public License
### along with stage0. If not, see <http://www.gnu.org/licenses/>.
### elf32.hex2: 32 bit elf header in hex2
## ELF Header
7F 45 4C 46 # e_ident[EI_MAG0-3] ELF's magic number
01 # e_ident[EI_CLASS] Indicating 32 bit
01 # e_ident[EI_DATA] Indicating little endianness
01 # e_ident[EI_VERSION] Indicating original elf
00 # e_ident[EI_OSABI] Set at 0 because none cares
00 # e_ident[EI_ABIVERSION] See above
00 00 00 00 00 00 00 # e_ident[EI_PAD]
02 00 # e_type Indicating Executable
03 00 # e_machine Indicating AMD64
01 00 00 00 # e_version Indicating original elf
54 80 04 08 # e_entry Address of the entry point
34 00 00 00 # e_phoff Address of program header table
00 00 00 00 # e_shoff Address of section header table
00 00 00 00 # e_flags
34 00 # e_ehsize Indicating our 52 Byte header
20 00 # e_phentsize size of a program header table
01 00 # e_phnum number of entries in program table
00 00 # e_shentsize size of a section header table
00 00 # e_shnum number of entries in section table
00 00 # e_shstrndx index of the section names
## Program Header
01 00 00 00 # p_type
00 00 00 00 # p_offset
00 80 04 08 # p_vaddr
00 80 04 08 # p_physaddr
## FIXME!
##60 00 00 00 # p_filesz
##60 00 00 00 # p_memsz
#65 01 00 00 # p_filesz
#65 01 00 00 # p_memsz
00 20 00 00 # p_filesz
00 20 00 00 # p_memsz
07 00 00 00 # p_flags
01 00 00 00 # alignment
## _start
# exit (42) -- works!
#bb 2a 00 00 00 # mov $42,%ebx
#b8 01 00 00 00 # mov $0x1,%eax
#cd 80 # int $0x80