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

mescc: Beginning of expression and test template.

Browse source 
* scaffold/t.c: New file.
* GNUmakefile (mescc-check, t-check): New targets.
* module/language/c99/compiler.mes (write-any): Catch weirdness.
  (make): Add <function> slot.
  (.function): New accessor.
  (clone): Handle it.
  (function->info): Set it.
  (ast->info): Make tests generic in if, for, while.  Add goto, label,
  !, ==, !=, -, &&.
* module/mes/elf-util.mes (lambda/label->list): New function.
  (text->list): Use it.
  (functions->text, function-prefix): New function.
  (function-offset): Use it.
  (label-offset): New function.
* module/mes/elf-util.scm (mes): Export them.
* module/mes/elf.mes (make-elf): Use text->list.
* module/mes/libc-i386.mes (eputs, puts): Remove.
  (i386:byte-base-sub): Rename from sub-byte-base.
  (i386:byte-jump-z): Rename from i386:Xjump-byte-z.
  (i386:byte-mem->accu): Rename from i386:Xmem-byte->accu.
  (i386:byte-mem->base): Rename from i386:Xmem-byte->base.
  (i386:accu->local, i386:accu-non-zero?, i386:accu-zero?,
  i386:base-sub, i386:byte-sub-base, i386:jump-c, i386:jump-cz,
  i386:jump-nc, i386:jump-ncz, i386:byte-mem->base, i386:sub-base,
  i386:test-accu, i386:test-base, i386:test-jump-z, i386:value->base,
  i386:xor-zf): New functions.
This commit is contained in:
Jan Nieuwenhuizen 2017-04-02 12:23:00 +02:00
parent 8d1e001ab2
commit c83ef66265
12 changed files with 693 additions and 304 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
GNUmakefile
View file

@ -35,21 +35,6 @@ mes.o: math.c math.h math.i math.environment.i
mes.o: posix.c posix.h posix.i posix.environment.i
mes.o: reader.c reader.h reader.i reader.environment.i
mini-mes: doc/examples/mini-mes.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -o mini-mes '-DVERSION="0.4"' $<
chmod +x $@
micro-mes: doc/examples/micro-mes.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o micro-mes '-DVERSION="0.4"' $<
chmod +x $@
main: doc/examples/main.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o main '-DVERSION="0.4"' $<
chmod +x $@
clean:
rm -f mes mes.o *.environment.i *.symbols.i *.environment.h *.cat a.out
@ -59,7 +44,7 @@ distclean: clean
%.h %.i %.environment.i %.symbols.i: %.c build-aux/mes-snarf.scm
build-aux/mes-snarf.scm $<
check: all guile-check mes-check
check: all guile-check mes-check mescc-check
TESTS:=\
tests/read.test\
@ -95,6 +80,8 @@ MES_DEBUG:=1
mes-check: all
set -e; for i in $(TESTS); do ./$$i; done
mes-check-nyacc: all
scripts/nyacc.mes
scripts/nyacc-calc.mes
@ -107,9 +94,37 @@ guile-check:
set -e; for i in $(TESTS); do\
$(GUILE) -s <(cat $(MES-0) module/mes/test.mes $$i);\
done
guile/nyacc.scm
guile/nyacc-calc.scm
t-check: t
./t
mescc-check: t-check
rm -f a.out
guile/mescc.scm scaffold/t.c > a.out
chmod +x a.out
./a.out
mini-mes: scaffold/mini-mes.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<
chmod +x $@
micro-mes: scaffold/micro-mes.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o $@ '-DVERSION="0.4"' $<
chmod +x $@
main: doc/examples/main.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o $@ '-DVERSION="0.4"' $<
chmod +x $@
t: scaffold/t.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o $@ '-DVERSION="0.4"' $<
chmod +x $@
MAIN_C:=doc/examples/main.c
mescc: all $(MAIN_C)
rm -f a.out

54
doc/examples/main.c
View file

@ -1,5 +1,24 @@
#if __GNUC__
/* -*-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/>.
*/
#if __GNUC__
void
write (int fd, char const* s, int n)
{
@ -52,14 +71,22 @@ puts (char const* s)
write (1, s, i);
return 0;
}
int
strcmp (char const* a, char const* b)
{
while (*a && *b && *a == *b) {a++;b++;}
return *a - *b;
}
#endif
int
main ()
//main ()
main (int argc, char *argv[])
{
int i = 0;
if (argc > 1 && !strcmp (argv[1], "--help")) puts ("argc > 1 && --help\n");
puts ("Hi Mes!\n");
for (int i = 0; i < 4; ++i)
puts (" Hello, world!\n");
return 42;
}
@ -67,7 +94,24 @@ main ()
void
_start ()
{
int r=main ();
// int r=main ();
// exit (r);
int r;
asm (
"mov %%ebp,%%eax\n\t"
"addl $8,%%eax\n\t"
"push %%eax\n\t"
"mov %%ebp,%%eax\n\t"
"addl $4,%%eax\n\t"
"movzbl (%%eax),%%eax\n\t"
"push %%eax\n\t"
"call main\n\t"
"movl %%eax,%0\n\t"
: "=r" (r)
: //no inputs "" (&main)
);
exit (r);
}
#endif

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

@ -62,6 +62,7 @@
(define (write-any x)
(write-char (cond ((char? x) x)
((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a\n" x) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
(else (stderr "write-any: ~a\n" x) barf))))
@ -87,13 +88,15 @@
(define <functions> '<functions>)
(define <globals> '<globals>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
(define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
(define* (make o #:key (functions '()) (globals '()) (locals '()) (function #f) (text '()))
(pmatch o
(<info> (list <info>
(cons <functions> functions)
(cons <globals> globals)
(cons <locals> locals)
(cons <function> function)
(cons <text> text)))))
(define (.functions o)
@ -108,6 +111,10 @@
(pmatch o
((<info> . ,alist) (assq-ref alist <locals>))))
(define (.function o)
(pmatch o
((<info> . ,alist) (assq-ref alist <function>))))
(define (.text o)
(pmatch o
((<info> . ,alist) (assq-ref alist <text>))))
@ -120,14 +127,16 @@
(let ((functions (.functions o))
(globals (.globals o))
(locals (.locals o))
(function (.function o))
(text (.text o)))
(let-keywords rest
#f
((functions functions)
(globals globals)
(locals locals)
(function function)
(text text))
(make <info> #:functions functions #:globals globals #:locals locals #:text text))))))
(make <info> #:functions functions #:globals globals #:locals locals #:function function #:text text))))))
(define (ref-local locals)
(lambda (o)
@ -214,7 +223,8 @@
(define (add-local name)
(acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
;; (stderr "S=~a\n" o)
;; (stderr "\nS=~a\n" o)
;; (stderr " text=~a\n" text)
;; (stderr " info=~a\n" info)
;; (stderr " globals=~a\n" globals)
(pmatch o
@ -228,68 +238,46 @@
((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
((expr-stmt (fctn-call (p-expr (ident ,name))
(expr-list (p-expr (string ,string)))))
;;(stderr "S1 string=~a\n" string)
(if (equal? name "asm") (clone info #:text (append text (list (lambda (f g t d) (asm->hex string)))))
(let ((globals (append globals (list (string->global string)))))
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
(clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
(let* ((globals (append globals (filter-map expr->global expr-list)))
(args (map (expr->arg globals locals) expr-list)))
(clone info #:text
(append text (list (lambda (f g t d)
(i386:call f g t d
(+ t (function-offset name f))
(+ d (data-offset string g))))))
(apply i386:call (cons* f g t d
(+ t (function-offset name f)) args)))))
#:globals globals))))
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
;;(stderr "S1 expr-list=~a\n" expr-list)
(let* ((globals (append globals (filter-map expr->global expr-list)))
(args (map (expr->arg globals locals) expr-list)))
(clone info #:text
(append text (list (lambda (f g t d)
(apply i386:call (cons* f g t d
(+ t (function-offset name f)) args)))))
#:globals globals)))
((if (gt (p-expr (ident ,name)) (p-expr (fixed ,value))) ,body)
(let* ((value (string->number value))
(info (clone info #:text '()))
(body-info ((ast->info info) body))
(body-text (.text body-info))
((if ,test ,body)
(let* ((jump (pmatch test
((lt ,a ,b) i386:jump-nc)
((gt ,a ,b) i386:jump-nc)
(_ i386:jump-z)))
(jump-text (lambda (body-length)
(list (lambda (f g t d) (jump body-length)))))
(test-info ((ast->info info) test))
(test+jump-info (clone test-info #:text (append (.text test-info)
(jump-text 0))))
(text-length (length (.text test+jump-info)))
(body-info ((ast->info test+jump-info) body))
(body-text (list-tail (.text body-info) text-length))
(body-length (length (text->list body-text))))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local-test (assoc-ref locals name) value)
(i386:jump-le body-length))))
(append (.text test-info)
(jump-text body-length)
body-text)
#:globals (.globals body-info))))
((if (not (fctn-call . ,call)) ,body)
(let* ((call-info ((ast->info info) `(expr-stmt (fctn-call . ,call))))
(info (clone info #:text '()))
(body-info ((ast->info info) body))
(body-text (.text body-info))
(body-length (length (text->list body-text))))
((for ,init ,test ,step ,body)
(let* ((jump (pmatch test
((lt ,a ,b) i386:jump-c)
((gt ,a ,b) i386:jump-c)
(_ i386:jump-nz)))
(jump-text (lambda (body-length)
(list (lambda (f g t d) (jump body-length)))))
(clone info #:text
(append (.text call-info)
(list (lambda (f g t d)
(append
;;(i386:local-test (assoc-ref locals name) 0)
;;(i386:accu-test (assoc-ref locals name) 0)
(i386:jump-nz body-length))))
body-text)
#:globals (append (.globals call-info)
(.globals body-info)))))
(;;(for ,init ,test ,step ,body)
(for ,init
;; FIXME: ,test
(lt (p-expr (ident ,name)) (p-expr (fixed ,value)))
,step ,body)
(let* ((value (string->number value))
(info (clone info #:text '()))
(info ((ast->info info) init))
@ -306,30 +294,32 @@
(step-text (.text step-info))
(step-length (length (text->list step-text)))
;; (test-info ((ast->info info) test))
;; (test-text (.text test-info))
;; (test-length (length (text->list test-text)))
)
(test-info ((ast->info info) test))
(test-text (.text test-info))
(test-length (length (text->list test-text))))
(clone info #:text
(append text
init-text
(list (lambda (f g t d) (i386:jump body-length)))
(list (lambda (f g t d) (i386:jump (+ 2 body-length)))) ;; FIXME: 2
body-text
step-text
;;test-text
;;(list (lambda (f g t d) (i386:jump-byte-nz (- (+ body-length test-length)))))
(list (lambda (f g t d)
(append
(i386:local-test (assoc-ref init-locals name) value)
(i386:jump-le (- (+ body-length step-length 2) ;;test-length
)))))
)
#:globals (append globals (.globals body-info))
test-text
(jump-text (- (+ body-length step-length test-length))))
#:globals (append globals (.globals body-info)) ;; FIXME
#:locals locals)))
((while ,test ,body)
(let* ((info (clone info #:text '()))
(let* ((jump (pmatch test
((lt ,a ,b) i386:jump-c)
((gt ,a ,b) i386:jump-c)
;;(_ i386:jump-nz)
(_ i386:jump-byte-nz) ;; FIXME
))
(jump-text (lambda (body-length)
(list (lambda (f g t d) (jump body-length)))))
(info (clone info #:text '()))
(body-info ((ast->info info) body))
(body-text (.text body-info))
(body-length (length (text->list body-text)))
@ -340,20 +330,72 @@
(clone info #:text
(append text
(list (lambda (f g t d) (i386:jump body-length)))
(list (lambda (f g t d) (i386:jump (+ 2 body-length)))) ;; FIXME: 2
body-text
test-text
(list (lambda (f g t d) (i386:jump-byte-nz (- (+ body-length test-length))))))
#:globals (append globals (.globals body-info)))))
(jump-text (- (+ body-length test-length))))
#:globals (.globals body-info))))
;;(and (and (de-ref (p-expr (ident "a"))) (de-ref (p-expr (ident "b")))) (eq (de-ref (p-expr (ident "a"))) (de-ref (p-expr (ident "b")))))
((labeled-stmt (ident ,label) ,statement)
(let ((info (clone info #:text (append text (list label)))))
((ast->info info) statement)))
((goto (ident ,label))
(let ((offset (length (text->list text))))
(clone info #:text
(append text
(list (lambda (f g t d)
(i386:jump (- (label-offset (.function info) label f) offset))))))))
((p-expr (ident ,name))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local->accu (assoc-ref locals name))
(i386:accu-zero?)))))))
((p-expr (fixed ,value))
(let ((value (string->number value)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append (i386:value->accu value)
(i386:accu-zero?))))))))
((de-ref (p-expr (ident ,name)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append (i386:local->accu (assoc-ref locals name))
(i386:Xmem-byte->accu)))))))
(i386:byte-mem->accu)))))))
((fctn-call . ,call)
(let ((info ((ast->info info) `(expr-stmt ,o))))
(clone info #:text
(append (.text info)
(list (lambda (f g t d)
(i386:accu-zero?)))))))
;; i++
((expr-stmt (post-inc (p-expr (ident ,name))))
(clone info #:text
(append text (list (lambda (f g t d)
(i386:local-add (assoc-ref locals name) 1))))))
;; ++i -- same for now FIXME
((expr-stmt (pre-inc (p-expr (ident ,name))))
(clone info #:text
(append text (list (lambda (f g t d)
(i386:local-add (assoc-ref locals name) 1))))))
((not ,expr)
(let* ((test-info ((ast->info info) expr)))
(clone info #:text
(append (.text test-info)
(list (lambda (f g t d)
(i386:xor-zf))))
#:globals (.globals test-info))))
((and ,a ,b)
(let* ((info (clone info #:text '()))
@ -372,26 +414,74 @@
2)))) ;; FIXME: need jump after last test
b-text))))
;; FIXME and, gt
((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(append (i386:local->accu (assoc-ref locals a))
(i386:Xmem-byte->base)
(i386:byte-mem->base)
(i386:local->accu (assoc-ref locals b))
(i386:Xmem-byte->accu)
(i386:test-byte-base))))))))
(i386:byte-mem->accu)
(i386:byte-test-base))))))))
((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
;; (stderr "GT: ~a > ~a\n" a b)
(let ((b (string->number b)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local->base (assoc-ref locals a))
(i386:value->accu b)
(i386:sub-base))))))))
((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
;;(stderr "EQ: ~a > ~a\n" a b)
(let ((b (string->number b)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local->base (assoc-ref locals a))
(i386:value->accu b)
(i386:sub-base)
(i386:xor-zf))))))))
((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
;;(stderr "NE: ~a > ~a\n" a b)
(let ((b (string->number b)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local->base (assoc-ref locals a))
(i386:value->accu b)
(i386:sub-base))))))))
((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
;;(stderr "LT: ~a < ~a\n" a b)
(let ((b (string->number b)))
(clone info #:text
(append text
(list (lambda (f g t d)
(append
(i386:local->base (assoc-ref locals a))
(i386:value->accu b)
(i386:base-sub))))))))
((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
(clone info #:text
(append text
(list (lambda (f g t d)
(append (i386:local->accu (assoc-ref locals a))
(i386:Xmem-byte->base)
(i386:byte-mem->base)
(i386:local->accu (assoc-ref locals b))
(i386:Xmem-byte->accu)
(i386:sub-byte-base)))))))
(i386:byte-mem->accu)
(i386:byte-sub-base)))))))
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
(let ((value (string->number value)))
@ -400,7 +490,7 @@
(append
((ident->base locals) name)
(i386:value->accu value)
(i386:mem-byte->accu)))))))) ; FIXME: type: char
(i386:byte-mem->accu)))))))) ; FIXME: type: char
((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
(clone info #:text
@ -408,19 +498,7 @@
(append
((ident->base locals) name)
((ident->accu locals) index)
(i386:mem-byte->accu))))))) ; FIXME: type: char
;; i++
((expr-stmt (post-inc (p-expr (ident ,name))))
(clone info #:text
(append text (list (lambda (f g t d)
(i386:local-add (assoc-ref locals name) 1))))))
;; ++i -- same for now FIXME
((expr-stmt (pre-inc (p-expr (ident ,name))))
(clone info #:text
(append text (list (lambda (f g t d)
(i386:local-add (assoc-ref locals name) 1))))))
(i386:byte-mem->accu))))))) ; FIXME: type: char
((return ,expr)
(let ((accu ((expr->accu info) expr)))
@ -480,6 +558,11 @@
(let ((value (string->number value)))
(clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
;; i = 0; ...from for init FIXME
((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
(let ((value (string->number value)))
(clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals name) value)))))))
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
(let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
(clone info #:text (append (.text info) (list (lambda (f g t d) (i386:ret-local (assoc-ref locals name))))))))
@ -529,17 +612,20 @@
(define (function->info info)
(lambda (o)
;;(stderr "\n")
(format (current-error-port) "compiling ~a\n" (.name o))
;;(stderr "formals=~a\n" (.formals o))
(let* ((text (formals->text (.formals o)))
(let* ((name (.name o))
(text (formals->text (.formals o)))
(locals (formals->locals (.formals o))))
(format (current-error-port) "compiling ~a\n" name)
;;(stderr "locals=~a\n" locals)
(let loop ((statements (.statements o))
(info (clone info #:locals locals #:text text)))
(info (clone info #:locals locals #:function name #:text text)))
(if (null? statements) (clone info
#:function #f
#:functions (append (.functions info) (list (cons (.name o) (.text info)))))
(let* ((statement (car statements)))
(loop (cdr statements) ((ast->info info) (car statements)))))))))
(loop (cdr statements)
((ast->info info) (car statements)))))))))
(define (ast-list->info info)
(lambda (elements)

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

@ -34,22 +34,38 @@
(define (functions->lambdas functions)
(append-map cdr functions))
(define (lambda/label->list f g t d)
(lambda (l/l)
(if (not (procedure? l/l)) '() (l/l f g t d))))
(define (text->list o)
(append-map (lambda (f) (f '() '() 0 0)) o))
(append-map (lambda/label->list '() '() 0 0) o))
(define (functions->text functions globals t d)
(let loop ((lambdas (functions->lambdas functions)) (text '()))
(if (null? lambdas) text
(loop (cdr lambdas)
(append text ((car lambdas) functions globals (- (length text)) d))))))
(let loop ((lambdas/labels (functions->lambdas functions)) (text '()))
(if (null? lambdas/labels) text
(loop (cdr lambdas/labels)
(append text ((lambda/label->list functions globals (- (length text)) d) (car lambdas/labels)))))))
(define (function-prefix name functions)
(member name (reverse functions) (lambda (a b) (equal? (car b) name))))
(define (function-offset name functions)
(let* ((prefix (member name (reverse functions)
(lambda (a b)
(equal? (car b) name)))))
(let ((prefix (function-prefix name functions)))
(if prefix (length (functions->text (cdr prefix) '() 0 0))
0)))
(define (label-offset function label functions)
(let ((prefix (function-prefix function functions)))
(if (not prefix) 0
(let ((function-entry (car prefix)))
(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) l/l))
(n (length t)))
(+ (loop (cdr text)) n))))))))
(define (globals->data globals)
(append-map cdr globals))

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

@ -26,8 +26,10 @@
#:use-module (srfi srfi-1)
#:export (data-offset
function-offset
label-offset
functions->lambdas
functions->text
lambda/label->list
text->list
globals->data))

2
module/mes/elf.mes
View file

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

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

@ -31,13 +31,6 @@
(define (i386:function-locals)
'(#x83 #xec #x10)) ; sub $0x10,%esp -- 4 local vars
;; (define (i386:formal i n)
;; (case i
;; ((0) (list #x8b #x5d (* (- n 2) 4))) ; mov $00(%ebp),%ebx
;; ((1) (list #x8b #x4d (* (- n 3) 4))) ; mov $00(%ebp),%ecx
;; ((2) (list #x8b #x55 (* (- n 4) 4))) ; mov $00(%ebp),%edx
;; ((3) (list #x8b #x45 (* (- n 5) 4))))) ; mov $00(%ebp),%eax FIXME
(define (i386:ref-global o)
`(#x68 ,@(int->bv32 o))) ; push $0x<o>
@ -51,9 +44,10 @@
(define (i386:push-arg f g t d)
(lambda (o)
(cond ((number? o)
`(#x68 ,@(int->bv32 o))) ; push $<o>
`(#x68 ,@(int->bv32 o))) ; push $<o>
((pair? o) o)
((procedure? o) (o f g t d)))))
((procedure? o) (o f g t d))
(_ barf))))
(define (i386:ret . rest)
(lambda (f g t d)
@ -76,6 +70,10 @@
(define (i386:accu-zero?)
`(#x85 #xc0)) ; cmpl %eax,%eax
(define (i386:accu-non-zero?)
(append '(#x85 #xc0) ; cmpl %eax,%eax
(i386:xor-zf)))
(define (i386:local->accu n)
(or n la)
`(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax
@ -84,14 +82,11 @@
(or n lb)
`(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx
(define (i386:mem-byte->accu)
(define (i386:byte-mem->accu)
'(#x01 #xd0 ; add %edx,%eax
#x0f #xb6 #x00)) ; movzbl (%eax),%eax
(define (i386:Xmem-byte->accu)
'(#x0f #xb6 #x00)) ; movzbl (%eax),%eax
(define (i386:Xmem-byte->base)
(define (i386:byte-mem->base)
'(#x0f #xb6 #x10)) ; movzbl (%eax),%edx
(define (i386:mem->accu)
@ -101,6 +96,9 @@
(define (i386:value->accu v)
`(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax
(define (i386:value->base v)
`(#xba ,@(int->bv32 v))) ; mov $<v>,%edx
(define (i386:local-add n v)
(or n ladd)
`(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $<v>,0x<n>(%ebp)
@ -130,6 +128,66 @@
#x83 #xc4 ,(* n 4) ; add $00,%esp
)))
(define (i386:xor-zf)
'(#x9f ; lahf
#x80 #xf4 #x40 ; xor $0x40,%ah
#x9e)) ; sahf
(define (i386:test-accu)
'(#x85 #xc0)) ; test %eax,%eax
(define (i386:jump n)
`(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp <n>
(define (i386:jump-c n)
`(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n>
(define (i386:jump-cz n)
`(#x76 ,(if (>= n 0) n (- n 2)))) ; jna <n>
(define (i386:jump-ncz n)
`(#x77 ,(if (>= n 0) n (- n 2)))) ; ja <n>
(define (i386:jump-nc n)
`(#x73 ,(if (>= n 0) n (- n 2)))) ; jnc <n>
(define (i386:jump-z n)
`(#x74 ,(if (>= n 0) n (- n 2)))) ; jz <n>
(define (i386:jump-nz n)
`(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz <n>
(define (i386:test-jump-z n)
`(#x85 #xc0 ; test %eax,%eax
#x74 ,(if (>= n 0) n (- n 4)))) ; jz <n>
(define (i386:jump-byte-nz n)
`(#x84 #xc0 ; test %al,%al
#x75 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:jump-byte-z n)
`(#x84 #xc0 ; test %al,%al
#x74 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:byte-test-base)
`(#x38 #xc2)) ; cmp %al,%dl
(define (i386:test-base)
`(#x39 #xd0)) ; cmp %edx,%eax
(define (i386:byte-sub-base)
`(#x28 #xd0)) ; sub %dl,%al
(define (i386:byte-base-sub)
`(#x28 #xd0)) ; sub %al,%dl
(define (i386:sub-base)
`(#x29 #xd0)) ; sub %edx,%eax
(define (i386:base-sub)
`(#x29 #xc2)) ; sub %eax,%edx
;;; libc bits
(define (i386:exit f g t d)
`(
#x5b ; pop %ebx
@ -138,26 +196,6 @@
#xcd #x80 ; int $0x80
))
;; (define (i386:_start f g t d)
;; (let* ((prefix
;; `(
;; #x55 ; push %ebp
;; #x89 #xe5 ; mov %esp,%ebp
;; ;;#x83 #xec #x10 ; sub $0x10,%esp -- 4 local vars
;; #xe8 ,@(int->bv32 (- address 5 s)) ; call relative
;; #xb8 #x04 #x00 #x00 #x00 ; mov $0x4,%eax
;; #xcd #x80 ; int $0x80
;; #xc9 ; leave
;; #xc3 ; ret
;; ))
;; (text-list (text->list t))
;; (statement-offset (- (+ (length prefix) (length text-list))))
;; (address (+ t (function-offset "main" s))))))
(define (i386:write f g t d)
`(
#x55 ; push %ebp
@ -173,89 +211,3 @@
#xc9 ; leave
#xc3 ; ret
))
(define (i386:jump n)
`(#xeb ,(if (>= n 0) n (- n 2)))) ; jmp <n>
(define (i386:jump-le n)
`(#x7e ,(if (>= n 0) n (- n 4)))) ; jle <n>
(define (i386:jump-byte-nz n)
`(#x84 #xc0 ; test %al,%al
#x75 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:jump-nz n)
`(#x85 #xc0 ; test %eax,%eax
#x75 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:jump-byte-z n)
`(#x84 #xc0 ; test %al,%al
#x74 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:test-byte-base)
`(#x38 #xc2)) ; cmp %al,%dl
(define (i386:Xjump-byte-z n)
`(#x74 ,(if (>= n 0) n (- n 2)))) ; je <n>
(define (i386:sub-byte-base)
`(#x28 #xd0)) ; sub %dl,%al
;;28 d0 sub %dl,%al
;;28 c2 sub %al,%dl
;;29 d0 sub %edx,%eax
;;29 c2 sub %eax,%edx
#!
int
strcmp (char const* a, char const* b)
{
while (*a && *b && *a == *b)
{
a++;b++;
}
return *a == *b;
}
08048150 <strcmp>:
8048150: 55 push %ebp
8048151: 89 e5 mov %esp,%ebp
8048153: eb 08 jmp 804815d <strcmp+0xd>
<body>
8048155: 83 45 08 01 addl $0x1,0x8(%ebp)
8048159: 83 45 0c 01 addl $0x1,0xc(%ebp)
<test>
804815d: 8b 45 08 mov 0x8(%ebp),%eax
8048160: 0f b6 00 movzbl (%eax),%eax
8048163: 84 c0 test %al,%al
8048165: 74 1a je 8048181 <strcmp+0x31>
8048167: 8b 45 0c mov 0xc(%ebp),%eax
804816a: 0f b6 00 movzbl (%eax),%eax
804816d: 84 c0 test %al,%al
804816f: 74 10 je 8048181 <strcmp+0x31>
8048171: 8b 45 08 mov 0x8(%ebp),%eax
8048174: 0f b6 10 movzbl (%eax),%edx
8048177: 8b 45 0c mov 0xc(%ebp),%eax
804817a: 0f b6 00 movzbl (%eax),%eax
804817d: 38 c2 cmp %al,%dl
804817f: 74 d4 je 8048155 <strcmp+0x5>
<exit>
8048181: 8b 45 08 mov 0x8(%ebp),%eax
8048184: 0f b6 00 movzbl (%eax),%eax
8048187: 0f be d0 movsbl %al,%edx
804818a: 8b 45 0c mov 0xc(%ebp),%eax
804818d: 0f b6 00 movzbl (%eax),%eax
8048190: 0f be c0 movsbl %al,%eax
8048193: 29 c2 sub %eax,%edx
8048195: 89 d0 mov %edx,%eax
8048197: 5d pop %ebp
8048198: c3 ret
!#

44
module/mes/libc-i386.scm
View file

@ -27,39 +27,53 @@
(define-module (mes libc-i386)
#:use-module (srfi srfi-1)
#:use-module (mes elf)
#:export (i386:accu->local
#:export (
i386:accu->local
i386:accu-non-zero?
i386:accu-zero?
i386:base-sub
i386:byte-base-sub
i386:byte-mem->accu
i386:byte-mem->base
i386:byte-test-base
i386:byte-sub-base
i386:call
i386:exit
i386:formal
i386:function-preamble
i386:function-locals
i386:eputs
i386:function-preamble
i386:jump
i386:jump
i386:jump-byte-nz
i386:jump-byte-z
i386:jump-nz
i386:jump-c
i386:jump-cz
i386:jump-le
i386:local-add
i386:local-assign
i386:jump-nc
i386:jump-ncz
i386:jump-nz
i386:jump-z
i386:local->accu
i386:local->base
i386:local-add
i386:local-assign
i386:local-test
i386:mem->accu
i386:mem-byte->accu
i386:Xmem-byte->accu
i386:push-accu
i386:puts
i386:ref-global
i386:ref-local
i386:ret
i386:ret-local
i386:sub-base
i386:test-accu
i386:test-base
i386:test-jump-z
i386:value->accu
i386:write
i386:value->base
i386:xor-zf
i386:test-byte-base
i386:Xmem-byte->base
i386:Xjump-byte-z
i386:sub-byte-base
;; libc
i386:exit
i386:write
))
(cond-expand

107
scaffold/micro-mes.c
View file

@ -41,8 +41,8 @@ void
exit (int code)
{
asm (
"movl %0, %%ebx\n\t"
"movl $1, %%eax\n\t"
"movl $0,%%ebx\n\t"
"movl $1,%%eax\n\t"
"int $0x80"
: // no outputs "=" (r)
: "" (code)
@ -71,11 +71,10 @@ write (int fd, char const* s, int n)
int r;
//syscall (SYS_write, fd, s, n));
asm (
"mov %0, %%ebx\n\t"
"mov %1, %%ecx\n\t"
"mov %2, %%edx\n\t"
"mov $0x4, %%eax\n\t"
"mov %0,%%ebx\n\t"
"mov %1,%%ecx\n\t"
"mov %2,%%edx\n\t"
"mov $0x4,%%eax\n\t"
"int $0x80\n\t"
: // no outputs "=" (r)
: "" (fd), "" (s), "" (n)
@ -152,27 +151,7 @@ eputs (char const* s)
return 0;
}
int g_a;
int g_b;
#if 0
void
eputs2 (char const* s, int a)
{
g_a = a;
write (STDERR, s, strlen (s));
//return 0;
}
void
eputs3 (char const* s, int a, int b)
{
g_a = a;
g_b = b;
write (STDERR, s, strlen (s));
//return 0;
}
#if __GNUC__
char const*
itoa (int x)
{
@ -205,7 +184,6 @@ assert_fail (char* s)
eputs ("\n");
*((int*)0) = 0;
}
#endif
#define assert(x) ((x) ? (void)0 : assert_fail(#x))
@ -213,6 +191,34 @@ assert_fail (char* s)
#define true 1
typedef int bool;
typedef int SCM;
#if __GNUC__
bool g_debug = false;
#endif
int g_free = 0;
SCM g_symbols = 0;
SCM g_stack = 0;
SCM r0 = 0; // a/env
SCM r1 = 0; // param 1
SCM r2 = 0; // save 2+load/dump
SCM r3 = 0; // continuation
SCM
mes_environment ()
{
return 0;
}
SCM
bload_env (SCM a) ///((internal))
{
eputs ("bload_env\n");
return 0;
}
int
main (int argc, char *argv[])
{
@ -222,14 +228,51 @@ main (int argc, char *argv[])
{
puts ("\narg1=");
puts (argv[1]);
if (!strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE");
if (!strcmp (argv[1], "--help")) /*return*/ puts ("XXUsage: mes [--dump|--load] < FILE");
}
puts ("\n");
eputs ("Strlen...\n");
puts ("Bye micro\n");
#if __GNUC__
//g_debug = getenv ("MES_DEBUG");
#endif
//if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");eputs (VERSION);return eputs ("\n");};
#if __GNUC__
g_stdin = STDIN;
r0 = mes_environment ();
#endif
#if MES_MINI
SCM program = bload_env (r0);
puts ("Hello micro-mes!\n");
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin;
r1 = eval_apply ();
stderr_ (r1);
eputs ("\n");
gc (g_stack);
#endif
int i = argc;
//int i = strcmp (argv[1], "1");
return i;
#if __GNUC__
if (g_debug)
{
eputs ("\nstats: [");
eputs (itoa (g_free));
eputs ("]\n");
}
#endif
return 0;
}
#if __GNUC__

23
scaffold/mini-mes.c
View file

@ -763,15 +763,26 @@ main (int argc, char *argv[])
return 0;
}
#if __GNUC__
void
_start ()
{
/* main body of program: call main(), etc */
/* exit system call */
int r;
asm (
"movl $1,%eax;"
"xorl %ebx,%ebx;"
"int $0x80"
"mov %%ebp,%%eax\n\t"
"addl $8,%%eax\n\t"
"push %%eax\n\t"
"mov %%ebp,%%eax\n\t"
"addl $4,%%eax\n\t"
"movzbl (%%eax),%%eax\n\t"
"push %%eax\n\t"
"call main\n\t"
"movl %%eax,%0\n\t"
: "=r" (r)
: //no inputs "" (&main)
);
exit (r);
}
#endif

203
scaffold/t.c Normal file
View file

@ -0,0 +1,203 @@
/* -*-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/>.
*/
#if __GNUC__
void
exit (int code)
{
asm (
"movl %0,%%ebx\n\t"
"movl $1,%%eax\n\t"
"int $0x80"
: // no outputs "=" (r)
: "" (code)
);
// not reached
exit (0);
}
void
write (int fd, char const* s, int n)
{
int r;
//syscall (SYS_write, fd, s, n));
asm (
"mov %0,%%ebx\n\t"
"mov %1,%%ecx\n\t"
"mov %2,%%edx\n\t"
"mov $0x4,%%eax\n\t"
"int $0x80\n\t"
: // no outputs "=" (r)
: "" (fd), "" (s), "" (n)
: "eax", "ebx", "ecx", "edx"
);
}
#define STDOUT 1
typedef long size_t;
size_t
strlen (char const* s)
{
int i = 0;
while (s[i]) i++;
return i;
}
int
puts (char const* s)
{
//write (STDOUT, s, strlen (s));
//int i = write (STDOUT, s, strlen (s));
int i = strlen (s);
write (1, s, i);
return 0;
}
int
strcmp (char const* a, char const* b)
{
while (*a && *b && *a == *b) {a++;b++;}
return *a - *b;
}
int test ();
#endif
int
main (int argc, char *argv[])
{
puts ("t.c\n");
return test ();
}
int
test ()
{
int f = 0;
int t = 1;
int one = 1;
puts ("t: if (0)\n");
if (0) return 1;
puts ("t: if (f)\n");
if (f) return 1;
puts ("t: if (one > 1)\n");
if (one > 1) return 1;
puts ("t: if (one < 0)\n");
if (one < 0) return 1;
puts ("t: stlrlen (\"\")\n");
if (strlen ("")) return 1;
puts ("t: if (!1)\n");
if (!1) return 1;
puts ("t: if (one == 0)\n");
if (one == 0) return 1;
puts ("t: if (f != 0)\n");
if (one != 1) return 1;
puts ("t: if (1 && 0)\n");
if (1 && 0) return 1;
puts ("t: if (1)\n");
if (1) goto ok0;
return 1;
ok0:
puts ("t: if (t)\n");
if (t) goto ok1;
return 1;
ok1:
puts ("t: if (one > 0)\n");
if (one > 0) goto ok2;
return 1;
ok2:
puts ("t: if (one < 2)\n");
if (one < 2) goto ok3;
return 1;
ok3:
puts ("t: if (strlen (\".\"))\n");
if (strlen (".")) goto ok4;
return 1;
ok4:
puts ("t: if (!0)\n");
if (!0) goto ok5;
return 1;
ok5:
puts ("t: if (one == 1)\n");
if (one == 1) goto ok6;
return 1;
ok6:
puts ("t: if (one != 0)\n");
if (one != 0) goto ok7;
return 1;
ok7:
puts ("t: if (1 && !0)\n");
if (1 && !0) goto ok8;
return 1;
ok8:
puts ("t: for (i=0; i<4; ++i)\n");
int i;
for (i=0; i<4; ++i);
if (i != 4) return i;
return 0;
}
#if __GNUC__
void
_start ()
{
// int r=main ();
// exit (r);
int r;
asm (
"mov %%ebp,%%eax\n\t"
"addl $8,%%eax\n\t"
"push %%eax\n\t"
"mov %%ebp,%%eax\n\t"
"addl $4,%%eax\n\t"
"movzbl (%%eax),%%eax\n\t"
"push %%eax\n\t"
"call main\n\t"
"movl %%eax,%0\n\t"
: "=r" (r)
: //no inputs "" (&main)
);
exit (r);
}
#endif

5
tests/optargs.test
View file

@ -56,7 +56,10 @@ exit $?
(pass-if "optargs key" ((lambda* (#:key (foo #f)) foo) #:foo #t))
(pass-if-equal "optargs key default" #f ((lambda* (#:key (foo #f)) foo)))
(mes-use-module (mes pmatch))
(cond-expand
(guile (use-modules (system base pmatch)
(ice-9 optargs)))
(mes (mes-use-module (mes pmatch))))
(define <info> '<info>)
(define <functions> '<functions>)