andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

mescc: Support goto in while body. 

* module/language/c99/compiler.mes (ast->info): Support goto in while
  body.
* doc/examples/t.c (test): Test it.
This commit is contained in:
Jan Nieuwenhuizen 2017-03-10 07:01:51 +01:00
parent f612feec47
commit f738d4381d
3 changed files with 29 additions and 324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
module/language/c99/compiler.mes
View File

@ -1232,7 +1232,7 @@
cases-info)) cases-info))
((for ,init ,test ,step ,body) ((for ,init ,test ,step ,body)
(let* ((info (clone info #:text '())) (let* ((info (clone info #:text '())) ;; FIXME: goto in body...
(info ((ast->info info) init)) (info ((ast->info info) init))
@ -1273,29 +1273,34 @@
#:locals locals))) #:locals locals)))
((while ,test ,body) ((while ,test ,body)
(let* ((info (clone info #:text '())) (let* ((skip-info (lambda (body-length)
(body-info ((ast->info info) body)) (clone info #:text (append text
(body-text (.text body-info)) (list (lambda (f g ta t d) (i386:Xjump body-length)))))))
(text (.text (skip-info 0)))
(text-length (length text))
(body-info (lambda (body-length)
((ast->info (skip-info body-length)) body)))
(body-text (list-tail (.text (body-info 0)) text-length))
(body-length (length (text->list body-text))) (body-length (length (text->list body-text)))
(test-jump->info ((test->jump->info info) test)) (body-info (body-info body-length))
(empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0)) (test+jump-info (test-jump->info 0))
(test-length (length (text->list (.text test+jump-info)))) (test-length (length (text->list (.text test+jump-info))))
(skip-body-text (list (lambda (f g ta t d)
(i386:Xjump body-length))))
(jump-text (list (lambda (f g ta t d) (jump-text (list (lambda (f g ta t d)
(i386:Xjump (- (+ body-length test-length)))))) (i386:Xjump (- (+ body-length test-length))))))
(jump-length (length (text->list jump-text))) (jump-length (length (text->list jump-text)))
(test-text (.text (test-jump->info jump-length)))) (test-text (.text (test-jump->info jump-length))))
(clone info #:text (clone info #:text
(append text (append
skip-body-text (.text body-info)
body-text test-text
test-text jump-text)
jump-text)
#:globals (.globals body-info)))) #:globals (.globals body-info))))
((labeled-stmt (ident ,label) ,statement) ((labeled-stmt (ident ,label) ,statement)
@ -1303,7 +1308,6 @@
((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 (text->list text))))) (offset (+ (length (jump 0)) (length (text->list text)))))
(clone info #:text (clone info #:text

315
scaffold/mini-mes.c
View File

@ -111,11 +111,6 @@ getchar ()
int r = read (g_stdin, &c, 1); int r = read (g_stdin, &c, 1);
if (r < 1) return -1; if (r < 1) return -1;
int i = c; int i = c;
if (i < 0) {
puts ("urg=");
puts (itoa (i));
puts ("\n");
}
if (i < 0) i += 256; if (i < 0) i += 256;
return i; return i;
} }
@ -471,25 +466,7 @@ SCM
make_cell (SCM type, SCM car, SCM cdr) make_cell (SCM type, SCM car, SCM cdr)
{ {
SCM x = alloc (1); SCM x = alloc (1);
#if DEBUG assert (TYPE (type) == NUMBER);
puts ("make_cell type=");
puts (itoa (type));
puts ("\n");
puts ("make_cell type.type=");
puts (itoa (TYPE (type)));
puts ("\n");
#endif
if (TYPE (type) != NUMBER)
{
puts ("type != NUMBER\n");
if (TYPE (type) < 10) puts ("type < 10\n");
if (TYPE (type) < 20) puts ("type < 20\n");
if (TYPE (type) < 30) puts ("type < 30\n");
if (TYPE (type) < 40) puts ("type < 40\n");
if (TYPE (type) < 50) puts ("type < 50\n");
if (TYPE (type) < 60) puts ("type < 60\n");
}
//assert (TYPE (type) == NUMBER);
TYPE (x) = VALUE (type); TYPE (x) = VALUE (type);
if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
if (car) CAR (x) = CAR (car); if (car) CAR (x) = CAR (car);
@ -523,11 +500,6 @@ tmp_num2_ (int x)
SCM SCM
cons (SCM x, SCM y) cons (SCM x, SCM y)
{ {
#if DEBUG
puts ("cons x=");
puts (itoa (x));
puts ("\n");
#endif
VALUE (tmp_num) = PAIR; VALUE (tmp_num) = PAIR;
return make_cell (tmp_num, x, y); return make_cell (tmp_num, x, y);
} }
@ -535,11 +507,6 @@ cons (SCM x, SCM y)
SCM SCM
car (SCM x) car (SCM x)
{ {
#if DEBUG
puts ("car x=");
puts (itoa (x));
puts ("\n");
#endif
#if MES_MINI #if MES_MINI
//Nyacc //Nyacc
//assert ("!car"); //assert ("!car");
@ -552,11 +519,6 @@ car (SCM x)
SCM SCM
cdr (SCM x) cdr (SCM x)
{ {
#if DEBUG
puts ("cdr x=");
puts (itoa (x));
puts ("\n");
#endif
#if MES_MINI #if MES_MINI
//Nyacc //Nyacc
//assert ("!cdr"); //assert ("!cdr");
@ -677,7 +639,6 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
SCM SCM
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
{ {
puts ("push cc\n");
SCM x = r3; SCM x = r3;
r3 = c; r3 = c;
r2 = p2; r2 = p2;
@ -700,47 +661,10 @@ SCM call (SCM,SCM);
SCM gc_pop_frame (); SCM gc_pop_frame ();
#endif #endif
SCM
cons_eval_apply ()
{
puts ("e/a: enter\n");
eval_apply:
// if (g_free + GC_SAFETY > ARENA_SIZE)
// gc_pop_frame (gc (gc_push_frame ()));
switch (r3)
{
case cell_vm_apply: {goto apply;}
case cell_unspecified: {return r1;}
}
SCM x = cell_nil;
SCM y = cell_nil;
apply:
puts ("e/a: apply\n");
switch (TYPE (car (r1)))
{
case TFUNCTION: {
puts ("apply.function\n");
//check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
r1 = call (car (r1), cdr (r1));
goto vm_return;
}
}
vm_return:
x = r1;
gc_pop_frame ();
r1 = x;
goto eval_apply;
}
SCM SCM
eval_apply () eval_apply ()
{ {
puts ("e/a: enter\n");
eval_apply: eval_apply:
puts ("e/a: eval_apply\n");
// if (g_free + GC_SAFETY > ARENA_SIZE) // if (g_free + GC_SAFETY > ARENA_SIZE)
// gc_pop_frame (gc (gc_push_frame ())); // gc_pop_frame (gc (gc_push_frame ()));
@ -777,7 +701,6 @@ eval_apply ()
SCM x = cell_nil; SCM x = cell_nil;
SCM y = cell_nil; SCM y = cell_nil;
evlis: evlis:
puts ("e/a: evlis\n");
if (r1 == cell_nil) goto vm_return; if (r1 == cell_nil) goto vm_return;
if (TYPE (r1) != PAIR) goto eval; if (TYPE (r1) != PAIR) goto eval;
push_cc (car (r1), r1, r0, cell_vm_evlis2); push_cc (car (r1), r1, r0, cell_vm_evlis2);
@ -790,7 +713,6 @@ eval_apply ()
goto vm_return; goto vm_return;
apply: apply:
puts ("e/a: apply\n");
switch (TYPE (car (r1))) switch (TYPE (car (r1)))
{ {
case TFUNCTION: { case TFUNCTION: {
@ -878,7 +800,6 @@ eval_apply ()
goto apply; goto apply;
eval: eval:
puts ("e/a: eval\n");
switch (TYPE (r1)) switch (TYPE (r1))
{ {
case PAIR: case PAIR:
@ -993,16 +914,12 @@ eval_apply ()
goto vm_return; goto vm_return;
#endif #endif
begin: begin:
puts ("e/a: begin\n");
x = cell_unspecified; x = cell_unspecified;
while (r1 != cell_nil) { while (r1 != cell_nil) {
if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR) if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR)
{ {
if (caar (r1) == cell_symbol_begin) if (caar (r1) == cell_symbol_begin)
{ r1 = append2 (cdar (r1), cdr (r1));
puts ("begin00\n");
r1 = append2 (cdar (r1), cdr (r1));
}
else if (caar (r1) == cell_symbol_primitive_load) else if (caar (r1) == cell_symbol_primitive_load)
{ {
push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
@ -1011,13 +928,11 @@ eval_apply ()
r1 = append2 (r1, cdr (r2)); r1 = append2 (r1, cdr (r2));
} }
} }
puts ("begin01\n");
if (CDR (r1) == cell_nil) if (CDR (r1) == cell_nil)
{ {
r1 = car (r1); r1 = car (r1);
goto eval; goto eval;
} }
puts ("begin02\n");
push_cc (CAR (r1), r1, r0, cell_vm_begin2); push_cc (CAR (r1), r1, r0, cell_vm_begin2);
goto eval; goto eval;
begin2: begin2:
@ -1072,7 +987,6 @@ eval_apply ()
goto apply; goto apply;
vm_return: vm_return:
puts ("e/a: vm-return\n");
x = r1; x = r1;
gc_pop_frame (); gc_pop_frame ();
r1 = x; r1 = x;
@ -1086,7 +1000,6 @@ SCM display_ (SCM);
SCM SCM
call (SCM fn, SCM x) call (SCM fn, SCM x)
{ {
puts ("call\n");
if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1) if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CAR (x)) == VALUES) && x != cell_nil && TYPE (CAR (x)) == VALUES)
x = cons (CADAR (x), CDR (x)); x = cons (CADAR (x), CDR (x));
@ -1094,22 +1007,6 @@ call (SCM fn, SCM x)
&& x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES) && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x))); x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
puts ("fn=");
display_ (fn);
#if __GNUC__
puts (itoa (fn));
puts (" .type=");
puts (itoa (TYPE (fn)));
puts (" .cdr=");
puts (itoa (CDR (fn)));
#endif
puts ("\n");
puts ("arity=");
#if __GNUC__
puts (itoa (FUNCTION (fn).arity));
#endif
puts ("\n");
switch (FUNCTION (fn).arity) switch (FUNCTION (fn).arity)
{ {
// case 0: return FUNCTION (fn).function0 (); // case 0: return FUNCTION (fn).function0 ();
@ -1404,15 +1301,10 @@ mes_builtins (SCM a)
scm_make_cell.cdr = g_function; scm_make_cell.cdr = g_function;
g_functions[g_function++] = fun_make_cell; g_functions[g_function++] = fun_make_cell;
cell_make_cell = g_free++; cell_make_cell = g_free++;
g_cells[cell_make_cell] = scm_make_cell; g_cells[cell_make_cell] = scm_make_cell;
scm_cons.cdr = g_function; scm_cons.cdr = g_function;
g_functions[g_function++] = fun_cons; g_functions[g_function++] = fun_cons;
#if __GNUC__
puts ("BUILTIN cons=");
puts (itoa (g_free));
puts ("\n");
#endif
cell_cons = g_free++; cell_cons = g_free++;
g_cells[cell_cons] = scm_cons; g_cells[cell_cons] = scm_cons;
@ -1426,41 +1318,22 @@ g_functions[g_function++] = fun_cdr;
cell_cdr = g_free++; cell_cdr = g_free++;
g_cells[cell_cdr] = scm_cdr; g_cells[cell_cdr] = scm_cdr;
#if 1
//scm_make_cell.string = cstring_to_list (scm_make_cell.name);
//g_cells[cell_make_cell].string = MAKE_STRING (scm_make_cell.string);
//a = acons (make_symbol (scm_make_cell.string), cell_make_cell, a);
puts ("00\n");
scm_make_cell.car = cstring_to_list (fun_make_cell.name); scm_make_cell.car = cstring_to_list (fun_make_cell.name);
puts ("01\n");
g_cells[cell_make_cell].car = MAKE_STRING (scm_make_cell.car); g_cells[cell_make_cell].car = MAKE_STRING (scm_make_cell.car);
puts ("02\n"); a = acons (make_symbol (scm_make_cell.car), cell_make_cell, a);
a = acons (make_symbol (scm_make_cell.car), cell_make_cell, a);
puts ("03\n");
//scm_cons.string = cstring_to_list (scm_cons.name);
//g_cells[cell_cons].string = MAKE_STRING (scm_cons.string);
//a = acons (make_symbol (scm_cons.string), cell_cons, a);
scm_cons.car = cstring_to_list (fun_cons.name); scm_cons.car = cstring_to_list (fun_cons.name);
g_cells[cell_cons].car = MAKE_STRING (scm_cons.car); g_cells[cell_cons].car = MAKE_STRING (scm_cons.car);
a = acons (make_symbol (scm_cons.car), cell_cons, a); a = acons (make_symbol (scm_cons.car), cell_cons, a);
//scm_car.string = cstring_to_list (scm_car.name);
//g_cells[cell_car].string = MAKE_STRING (scm_car.string);
//a = acons (make_symbol (scm_cons.string), cell_cons, a);
scm_car.car = cstring_to_list (fun_car.name); scm_car.car = cstring_to_list (fun_car.name);
g_cells[cell_car].car = MAKE_STRING (scm_car.car); g_cells[cell_car].car = MAKE_STRING (scm_car.car);
a = acons (make_symbol (scm_cons.car), cell_cons, a); a = acons (make_symbol (scm_cons.car), cell_cons, a);
//scm_cdr.string = cstring_to_list (scm_cdr.name);
//g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
//a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
scm_cdr.car = cstring_to_list (fun_cdr.name); scm_cdr.car = cstring_to_list (fun_cdr.name);
g_cells[cell_cdr].car = MAKE_STRING (scm_cdr.car); g_cells[cell_cdr].car = MAKE_STRING (scm_cdr.car);
a = acons (make_symbol (scm_cdr.car), cell_cdr, a); a = acons (make_symbol (scm_cdr.car), cell_cdr, a);
#endif
#endif #endif
return a; return a;
} }
@ -1493,101 +1366,6 @@ bload_env (SCM a) ///((internal))
return r2; return r2;
} }
SCM
fill ()
{
TYPE (0) = 0x6c6c6168;
CAR (0) = 0x6a746f6f;
CDR (0) = 0x00002165;
TYPE (1) = SYMBOL;
CAR (1) = 0x2d2d2d2d;
CDR (1) = 0x3e3e3e3e;
TYPE (9) = 0x2d2d2d2d;
CAR (9) = 0x2d2d2d2d;
CDR (9) = 0x3e3e3e3e;
#if 0
// (A(B))
TYPE (10) = PAIR;
CAR (10) = 11;
CDR (10) = 12;
TYPE (11) = CHAR;
CAR (11) = 0x58585858;
CDR (11) = 89;
TYPE (12) = PAIR;
CAR (12) = 13;
CDR (12) = 1;
TYPE (13) = CHAR;
CAR (13) = 0x58585858;
CDR (13) = 90;
TYPE (14) = 0x58585858;
CAR (14) = 0x58585858;
CDR (14) = 0x58585858;
TYPE (14) = 0x58585858;
CAR (14) = 0x58585858;
CDR (14) = 0x58585858;
#else
// (cons 0 1)
TYPE (10) = PAIR;
CAR (10) = 11;
CDR (10) = 12;
TYPE (11) = TFUNCTION;
CAR (11) = 0x58585858;
// 0 = make_cell
// 1 = cons
// 2 = car
CDR (11) = 1;
TYPE (12) = PAIR;
CAR (12) = 13;
//CDR (12) = 1;
CDR (12) = 14;
TYPE (13) = NUMBER;
CAR (13) = 0x58585858;
CDR (13) = 0;
TYPE (14) = PAIR;
CAR (14) = 15;
CDR (14) = 1;
TYPE (15) = NUMBER;
CAR (15) = 0x58585858;
CDR (15) = 1;
//g_stack@23
TYPE (19) = PAIR;
CAR (19) = 1;
CDR (19) = 1;
TYPE (20) = PAIR;
CAR (20) = 7;
CDR (20) = 19;
TYPE (21) = PAIR;
CAR (21) = 7;
CDR (21) = 20;
TYPE (22) = PAIR;
CAR (22) = 134;
CDR (22) = 21;
TYPE (23) = PAIR;
CAR (23) = 22;
CDR (23) = 137;
#endif
return 0;
}
SCM SCM
display_ (SCM x) display_ (SCM x)
{ {
@ -1716,17 +1494,11 @@ display_ (SCM x)
return 0; return 0;
} }
#define CONS 0
SCM SCM
simple_bload_env (SCM a) ///((internal)) simple_bload_env (SCM a) ///((internal))
{ {
puts ("reading: "); puts ("reading: ");
#if CONS
char *mo = "module/mes/hack-32.mo";
#else
char *mo = "mini-0-32.mo"; char *mo = "mini-0-32.mo";
#endif
puts (mo); puts (mo);
puts ("\n"); puts ("\n");
@ -1758,7 +1530,6 @@ simple_bload_env (SCM a) ///((internal))
c = getchar (); c = getchar ();
while (c != -1) while (c != -1)
{ {
putchar (c);
*p++ = c; *p++ = c;
c = getchar (); c = getchar ();
} }
@ -1791,17 +1562,9 @@ simple_bload_env (SCM a) ///((internal))
eputs ("\n"); eputs ("\n");
#endif #endif
#if CONS
if (g_free != 15) exit (33);
g_symbols = 1;
r2 = 10;
#endif
g_stdin = STDIN; g_stdin = STDIN;
r0 = mes_builtins (r0); r0 = mes_builtins (r0);
///if (g_free != 19) exit (34);
#if __GNUC__ #if __GNUC__
puts ("cells read: "); puts ("cells read: ");
puts (itoa (g_free)); puts (itoa (g_free));
@ -1816,19 +1579,6 @@ simple_bload_env (SCM a) ///((internal))
puts ("\n"); puts ("\n");
#endif #endif
#if CONS
display_ (r2);
puts ("\n");
fill ();
r2 = 10;
if (TYPE (12) != PAIR)
exit (33);
r0 = 1;
#endif
puts ("program["); puts ("program[");
#if __GNUC__ #if __GNUC__
puts (itoa (r2)); puts (itoa (r2));
@ -1908,67 +1658,12 @@ main (int argc, char *argv[])
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump (); if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
#endif #endif
//if (r2 != 10) r2 = CAR (r2);
push_cc (r2, cell_unspecified, r0, cell_unspecified); push_cc (r2, cell_unspecified, r0, cell_unspecified);
#if __GNUC__
// puts ("stack: ");
// display_ (g_stack);
// puts ("\n");
puts ("g_free=");
puts (itoa(g_free));
puts ("\n");
puts ("g_stack=");
puts (itoa(g_stack));
puts ("\n");
puts ("r0=");
puts (itoa(r0));
puts ("\n");
puts ("r1=");
puts (itoa(r1));
puts ("\n");
puts ("r2=");
puts (itoa(r2));
puts ("\n");
puts ("r3=");
puts (itoa(r3));
puts ("\n");
#endif
#if 0
// SKIP DINGES!
if (r1 != 10) r1 = CAR (r1);
puts ("r1=");
display_ (r1);
puts ("\n");
r3 = cell_vm_apply;
//r1 = cons_eval_apply ();
r1 = eval_apply ();
#else
r3 = cell_vm_begin; r3 = cell_vm_begin;
r1 = eval_apply (); r1 = eval_apply ();
#endif
#if __GNUC__
puts ("result r1=");
puts (itoa (r1));
puts ("\n");
puts ("result r1.type=");
puts (itoa (TYPE (r1)));
puts ("\n");
#endif
//stderr_ (r1);
display_ (r1); display_ (r1);
eputs ("\n"); eputs ("\n");
#if !MES_MINI #if !MES_MINI
gc (g_stack); gc (g_stack);
#endif #endif

6
scaffold/t.c
View File

@ -540,6 +540,12 @@ test (char *p)
return 1; return 1;
ok0: ok0:
puts ("t: while (1) { goto label; };\n");
while (1) {
goto ok00;
}
ok00:
puts ("t: if (0); return 1; else;\n"); puts ("t: if (0); return 1; else;\n");
if (0) return 1; else goto ok01; if (0) return 1; else goto ok01;
ok01: ok01: