mescc: Write object files in hex2 or hex3 format.

* 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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -29,8 +29,20 @@
(guile) (guile)
(guile-2) (guile-2)
(mes (mes
(mes-use-module (srfi srfi-1))
(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) (define (make-global name type pointer value)
(cons name (list type pointer value))) (cons name (list type pointer value)))
@ -43,28 +55,64 @@
(define (dec->hex o) (define (dec->hex o)
(cond ((number? o) (number->string o 16)) (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) (define (functions->lines functions)
(append-map (lambda (f) (or (cdr f) '())) 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 (lambda/label->list f g ta t d) )
(lambda (l/l)
(if (not (procedure? l/l)) '() (l/l f g ta t d))))
(define (text->list o) (define (text->list o)
(append-map (lambda/label->list '() '() 0 0 0) o)) (append-map cdr o))
(define functions->text (define functions->text
(let ((cache '())) (let ((cache '()))
(lambda (functions globals ta t d) (lambda (functions globals ta t d)
(or (assoc-ref cache (cons ta (map car functions))) (let ((text (or (assoc-ref cache (cons ta (map car functions)))
(let ((text (let loop ((lambdas/labels (functions->lambdas functions)) (text '())) (let ((text (apply append (functions->lines functions))))
(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)) (set! cache (assoc-set! cache (cons ta (map car functions)) text))
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) (define (function-prefix name functions)
;; FIXME ;; FIXME
@ -85,7 +133,7 @@
(if (null? (cdr prefix)) 0 (if (null? (cdr prefix)) 0
(function-offset (caar prefix) functions))))))) (function-offset (caar prefix) functions)))))))
(if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset))) (if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset)))
(or offset 0)))))) offset)))))
(define label-offset (define label-offset
(let ((cache '())) (let ((cache '()))
@ -95,26 +143,45 @@
(if (not prefix) 0 (if (not prefix) 0
(let* ((function-entry (car prefix)) (let* ((function-entry (car prefix))
(offset (let loop ((text (cdr function-entry))) (offset (let loop ((text (cdr function-entry)))
(if (or (equal? (car text) label) (null? text)) 0 ;; FIXME: unresolved label
(let* ((l/l (car text)) ;;(if (null? text) (error "unresolved label:"))
(t ((lambda/label->list '() '() 0 0 0) l/l)) (if (or (null? text) (equal? (car text) label)) 0
(n (length t))) (let* ((t (car text))
(n (if (and (pair? (car t))
(member (caar t) '(#:label #:comment))) 0 (length t))))
(+ (loop (cdr text)) n)))))) (+ (loop (cdr text)) n))))))
(when (> offset 0) (when (> offset 0)
(set! cache (assoc-set! cache (cons function label) offset))) (set! cache (assoc-set! cache (cons function label) offset)))
offset))))))) offset)))))))
(define (globals->data globals) (define (globals->data functions globals t d)
(append-map (compose global:value cdr) globals)) (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 (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)))))
(if (not prefix) 0 (and prefix
(let ((offset (length (globals->data (cdr prefix))))) (let ((offset (length (simple-globals->data (cdr prefix)))))
(set! cache (assoc-set! cache name offset)) (set! cache (assoc-set! cache name offset))
offset))))))) offset)))))))

View file

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

View file

@ -1,4 +1,4 @@
;;; -*-scheme-*- <;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
@ -28,19 +28,8 @@
(guile) (guile)
(mes (mes
(mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-1))
(mes-use-module (mes bytevectors))
(mes-use-module (mes elf-util)))) (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-addr int->bv32)
(define elf32-half int->bv16) (define elf32-half int->bv16)
(define elf32-off int->bv32) (define elf32-off int->bv32)
@ -213,7 +202,7 @@
(define text-address (+ text-offset vaddress)) (define text-address (+ text-offset vaddress))
(define data-length (define data-length
(length (globals->data globals))) (length (globals->data functions globals 0 0)))
(define comment-length (define comment-length
(length comment)) (length comment))
@ -241,10 +230,11 @@
(define SHF-STRINGS #x20) (define SHF-STRINGS #x20)
(let* ((text (functions->text functions globals text-address 0 data-address)) (let* ((text (functions->text functions globals text-address 0 data-address))
(raw-data (globals->data globals)) (raw-data (globals->data functions globals text-address data-address))
(data (let loop ((data raw-data) (init init)) ;; (data (let loop ((data raw-data) (init init))
(if (null? init) data ;; (if (null? init) data
(loop ((car init) functions globals text-address 0 data-address data) (cdr init))))) ;; (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
(data raw-data)
(entry (+ text-offset (function-offset "_start" functions))) (entry (+ text-offset (function-offset "_start" functions)))
(sym (sym functions globals)) (sym (sym functions globals))
(str (str functions))) (str (str functions)))
@ -291,3 +281,29 @@
sym sym
str str
(section-headers)))) (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))))

View file

@ -1,7 +1,7 @@
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software ;;; 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. ;;; This file is part of Mes.
;;; ;;;
@ -24,11 +24,9 @@
(define-module (mes elf) (define-module (mes elf)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (mes bytevectors)
#:use-module (mes elf-util) #:use-module (mes elf-util)
#:export (int->bv16 #:export (make-elf
int->bv32 object->elf))
make-elf))
(cond-expand (cond-expand
(guile-2) (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;
}

View file

@ -18,17 +18,11 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>. * along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/ */
#include <mlibc.h> #include <stdio.h>
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
puts ("Hi Mes!\n"); eputs ("Hello, Mescc!\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;}
return 42; return 42;
} }

View file

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

View file

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

View file

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

View file

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