diff --git a/lib.c b/lib.c index fa0df77d..cc09ea3a 100644 --- a/lib.c +++ b/lib.c @@ -154,6 +154,10 @@ FILE *g_stdin; int dump () { + fputs ("program r2=", stderr); + stderr_ (r2); + fputs ("\n", stderr); + r1 = g_symbols; gc_push_frame (); gc (); @@ -201,8 +205,13 @@ SCM load_env (SCM a) ///((internal)) { r0 = a; - g_stdin = fopen ("module/mes/read-0.mes", "r"); - g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r"); + if (getenv ("MES_MINI")) + g_stdin = fopen ("mini-0.mes", "r"); + else + { + g_stdin = fopen ("module/mes/read-0.mes", "r"); + g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r"); + } if (!g_function) r0 = mes_builtins (r0); r2 = read_input_file_env (r0); g_stdin = stdin; @@ -212,8 +221,13 @@ load_env (SCM a) ///((internal)) SCM bload_env (SCM a) ///((internal)) { +#if MES_MINI + g_stdin = fopen ("mini-0.mo", "r"); +#else g_stdin = fopen ("module/mes/read-0.mo", "r"); g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r"); +#endif + char *p = (char*)g_cells; assert (getchar () == 'M'); assert (getchar () == 'E'); diff --git a/mes.c b/mes.c index cc53d4a1..00d6244c 100644 --- a/mes.c +++ b/mes.c @@ -139,7 +139,7 @@ scm scm_vm_apply = {SPECIAL, "core:apply"}; scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"}; scm scm_vm_eval = {SPECIAL, "core:eval"}; -#if FIXED_PRIMITIVES +#if 1 //FIXED_PRIMITIVES scm scm_vm_eval_car = {SPECIAL, "*vm-eval-car*"}; scm scm_vm_eval_cdr = {SPECIAL, "*vm-eval-cdr*"}; scm scm_vm_eval_cons = {SPECIAL, "*vm-eval-cons*"}; diff --git a/module/mes/elf.mes b/module/mes/elf.mes index fa35bfa5..dcb52f6b 100644 --- a/module/mes/elf.mes +++ b/module/mes/elf.mes @@ -273,8 +273,10 @@ (+ str-offset str-length)) (format (current-error-port) "ELF text=~a\n" (map dec->hex text)) - (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data)) - (format (current-error-port) "ELF data=~a\n" (map dec->hex data)) + (if (< (length raw-data) 200) + (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data))) + (if (< (length data) 200) + (format (current-error-port) "ELF data=~a\n" (map dec->hex data))) (format (current-error-port) "text-offset=~a\n" text-offset) (format (current-error-port) "data-offset=~a\n" data-offset) (format (current-error-port) "_start=~a\n" (number->string entry 16)) diff --git a/scaffold/cons-mes.c b/scaffold/cons-mes.c index 5a4c95de..c579988c 100644 --- a/scaffold/cons-mes.c +++ b/scaffold/cons-mes.c @@ -1037,7 +1037,7 @@ display_ (SCM x) { //puts ("\n"); #if __GNUC__ - putchar (48 + VALUE (x)); + puts (itoa (VALUE (x))); #else int i; i = VALUE (x); @@ -1070,10 +1070,65 @@ display_ (SCM x) puts (")"); break; } + case SPECIAL: + { + switch (x) + { + case 1: {puts ("()"); break;} + case 2: {puts ("#f"); break;} + case 3: {puts ("#t"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } + case SYMBOL: + { + switch (x) + { + case 11: {puts (" . "); break;} + case 12: {puts ("lambda"); break;} + case 13: {puts ("begin"); break;} + case 14: {puts ("if"); break;} + case 15: {puts ("quote"); break;} + case 37: {puts ("car"); break;} + case 38: {puts ("cdr"); break;} + case 39: {puts ("null?"); break;} + case 40: {puts ("eq?"); break;} + case 41: {puts ("cons"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } default: { //puts ("\n"); +#if __GNUC__ + puts ("<"); + puts (itoa (TYPE (x))); + puts (":"); + puts (itoa (x)); + puts (">"); +#else puts ("_"); +#endif break; } } diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index 1b924cc5..794cd992 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -19,7 +19,7 @@ */ #define MES_MINI 1 -#define FIXED_PRIMITIVES 0 +#define FIXED_PRIMITIVES 1 #if __GNUC__ #define FIXME_NYACC 1 @@ -340,6 +340,12 @@ struct scm *g_cells = arena; #define cell_symbol_primitive_load 24 #define cell_symbol_read_input_file 25 +#define cell_symbol_car 37 +#define cell_symbol_cdr 38 +#define cell_symbol_null_p 39 +#define cell_symbol_eq_p 40 +#define cell_symbol_cons 41 + #define cell_vm_evlis 42 #define cell_vm_evlis2 43 #define cell_vm_evlis3 44 @@ -379,8 +385,12 @@ int g_function = 0; SCM make_cell (SCM type, SCM car, SCM cdr); #endif struct function fun_make_cell = {&make_cell, 3}; + +#if __GNUC__ +struct scm scm_make_cell = {TFUNCTION, "make-cell", 0}; +#else struct scm scm_make_cell = {TFUNCTION,0,0}; - //, "make-cell", 0}; +#endif SCM cell_make_cell; #if __GNUC__ @@ -388,8 +398,11 @@ SCM cell_make_cell; SCM cons (SCM x, SCM y); #endif struct function fun_cons = {&cons, 2}; -struct scm scm_cons = {TFUNCTION,0,0}; - // "cons", 0}; +#if __GNUC__ +struct scm scm_cons = {TFUNCTION,"cons", 0}; +#else +struct scm scm_make_cell = {TFUNCTION,0,0}; +#endif SCM cell_cons; #if __GNUC__ @@ -397,8 +410,11 @@ SCM cell_cons; SCM car (SCM x); #endif struct function fun_car = {&car, 1}; -struct scm scm_car = {TFUNCTION,0,0}; - // "car", 0}; +#if __GNUC__ +struct scm scm_car = {TFUNCTION,"car", 0}; +#else +struct scm scm_make_cell = {TFUNCTION,0,0}; +#endif SCM cell_car; #if __GNUC__ @@ -406,8 +422,11 @@ SCM cell_car; SCM cdr (SCM x); #endif struct function fun_cdr = {&cdr, 1}; -struct scm scm_cdr = {TFUNCTION,0,0}; -// "cdr", 0}; +#if __GNUC__ +struct scm scm_cdr = {TFUNCTION,"cdr", 0}; +#else +struct scm scm_make_cell = {TFUNCTION,0,0}; +#endif SCM cell_cdr; // SCM eq_p (SCM x, SCM y); @@ -462,11 +481,13 @@ alloc (int n) return x; } +#define DEBUG 0 + SCM make_cell (SCM type, SCM car, SCM cdr) { SCM x = alloc (1); -#if __GNUC__ +#if DEBUG puts ("make_cell type="); puts (itoa (type)); puts ("\n"); @@ -474,7 +495,17 @@ make_cell (SCM type, SCM car, SCM cdr) puts (itoa (TYPE (type))); puts ("\n"); #endif - assert (TYPE (type) == NUMBER); + 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); if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { if (car) CAR (x) = CAR (car); @@ -508,11 +539,11 @@ tmp_num2_ (int x) SCM cons (SCM x, SCM y) { +#if DEBUG puts ("cons x="); -#if __GNUC__ puts (itoa (x)); -#endif puts ("\n"); +#endif VALUE (tmp_num) = PAIR; return make_cell (tmp_num, x, y); } @@ -520,11 +551,11 @@ cons (SCM x, SCM y) SCM car (SCM x) { +#if DEBUG puts ("car x="); -#if __GNUC__ puts (itoa (x)); -#endif puts ("\n"); +#endif #if MES_MINI //Nyacc //assert ("!car"); @@ -537,11 +568,11 @@ car (SCM x) SCM cdr (SCM x) { +#if DEBUG puts ("cdr x="); -#if __GNUC__ puts (itoa (x)); -#endif puts ("\n"); +#endif #if MES_MINI //Nyacc //assert ("!cdr"); @@ -551,6 +582,12 @@ cdr (SCM x) return CDR(x); } +SCM +null_p (SCM x) +{ + return x == cell_nil ? cell_t : cell_f; +} + // SCM // eq_p (SCM x, SCM y) // { @@ -679,16 +716,47 @@ SCM call (SCM,SCM); SCM gc_pop_frame (); #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 eval_apply () { - puts ("e/a: fixme\n"); + puts ("e/a: enter\n"); eval_apply: - asm (".byte 0x90"); - asm (".byte 0x90"); - asm (".byte 0x90"); - asm (".byte 0x90"); - puts ("eval_apply\n"); + puts ("e/a: eval_apply\n"); // if (g_free + GC_SAFETY > ARENA_SIZE) // gc_pop_frame (gc (gc_push_frame ())); @@ -725,6 +793,7 @@ eval_apply () SCM x = cell_nil; SCM y = cell_nil; evlis: + puts ("e/a: evlis\n"); if (r1 == cell_nil) goto vm_return; if (TYPE (r1) != PAIR) goto eval; push_cc (car (r1), r1, r0, cell_vm_evlis2); @@ -737,7 +806,7 @@ eval_apply () goto vm_return; apply: - puts ("apply\n"); + puts ("e/a: apply\n"); switch (TYPE (car (r1))) { case TFUNCTION: { @@ -825,6 +894,7 @@ eval_apply () goto apply; eval: + puts ("e/a: eval\n"); switch (TYPE (r1)) { case PAIR: @@ -939,12 +1009,16 @@ eval_apply () goto vm_return; #endif begin: + puts ("e/a: begin\n"); x = cell_unspecified; while (r1 != cell_nil) { if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR) { 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) { push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); @@ -953,11 +1027,13 @@ eval_apply () r1 = append2 (r1, cdr (r2)); } } + puts ("begin01\n"); if (CDR (r1) == cell_nil) { r1 = car (r1); goto eval; } + puts ("begin02\n"); push_cc (CAR (r1), r1, r0, cell_vm_begin2); goto eval; begin2: @@ -1012,12 +1088,17 @@ eval_apply () goto apply; vm_return: + puts ("e/a: vm-return\n"); x = r1; gc_pop_frame (); r1 = x; goto eval_apply; } +#if __GNUC__ +SCM display_ (SCM); +#endif + SCM call (SCM fn, SCM x) { @@ -1028,6 +1109,23 @@ call (SCM fn, SCM x) if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES) 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) { // case 0: return FUNCTION (fn).function0 (); @@ -1054,7 +1152,8 @@ gc_peek_frame () { SCM frame = car (g_stack); r1 = car (frame); -#if __GNUC__ +#if 1 + //GNUC r2 = cadr (frame); r3 = car (cddr (frame)); r0 = cadr (cddr (frame)); @@ -1316,6 +1415,11 @@ cell_make_cell = g_free++; scm_cons.cdr = g_function; g_functions[g_function++] = fun_cons; +#if __GNUC__ + puts ("BUILTIN cons="); + puts (itoa (g_free)); + puts ("\n"); +#endif cell_cons = g_free++; g_cells[cell_cons] = scm_cons; @@ -1329,21 +1433,38 @@ g_functions[g_function++] = fun_cdr; cell_cdr = g_free++; g_cells[cell_cdr] = scm_cdr; -// 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); +//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 (scm_make_cell.car); + puts ("01\n"); +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); + 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.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 (scm_cons.car); +g_cells[cell_cons].car = MAKE_STRING (scm_cons.car); +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_car.string), cell_car, 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 (scm_car.car); +g_cells[cell_car].car = MAKE_STRING (scm_car.car); +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 (scm_cdr.car); +g_cells[cell_cdr].car = MAKE_STRING (scm_cdr.car); +a = acons (make_symbol (scm_cdr.car), cell_cdr, 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); #endif return a; } @@ -1501,7 +1622,7 @@ display_ (SCM x) { //puts ("\n"); #if __GNUC__ - putchar (48 + VALUE (x)); + puts (itoa (VALUE (x))); #else int i; i = VALUE (x); @@ -1534,10 +1655,65 @@ display_ (SCM x) puts (")"); break; } + case SPECIAL: + { + switch (x) + { + case 1: {puts ("()"); break;} + case 2: {puts ("#f"); break;} + case 3: {puts ("#t"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } + case SYMBOL: + { + switch (x) + { + case 11: {puts (" . "); break;} + case 12: {puts ("lambda"); break;} + case 13: {puts ("begin"); break;} + case 14: {puts ("if"); break;} + case 15: {puts ("quote"); break;} + case 37: {puts ("car"); break;} + case 38: {puts ("cdr"); break;} + case 39: {puts ("null?"); break;} + case 40: {puts ("eq?"); break;} + case 41: {puts ("cons"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } default: { //puts ("\n"); +#if __GNUC__ + puts ("<"); + puts (itoa (TYPE (x))); + puts (":"); + puts (itoa (x)); + puts (">"); +#else puts ("_"); +#endif break; } } @@ -1553,7 +1729,7 @@ simple_bload_env (SCM a) ///((internal)) #if CONS char *mo = "module/mes/hack-32.mo"; #else - char *mo = "cons-32.mo"; + char *mo = "mini-0-32.mo"; #endif puts (mo); @@ -1583,25 +1759,10 @@ simple_bload_env (SCM a) ///((internal)) puts ("\n"); #endif -// #if !CONS -// //FIXME: skip one cell -// for (int q=0; q < 12; q++) -// getchar (); -// #endif - - int i = 0; c = getchar (); while (c != -1) { -#if __GNUC__ - puts ("\ni="); - puts (itoa (i)); - puts (" "); - puts (itoa (c)); - puts (" "); -#endif putchar (c); - i++; *p++ = c; c = getchar (); } @@ -1609,23 +1770,14 @@ simple_bload_env (SCM a) ///((internal)) puts ("read done\n"); g_free = (p-(char*)g_cells) / sizeof (struct scm); - -#if !CONS gc_peek_frame (); -#endif - - // URG - // r0 = 628; - // r1 = 67; - // r2 = 389; + g_symbols = r1; #if __GNUC__ puts ("XXcells read: "); puts (itoa (g_free)); puts ("\n"); - g_symbols = r1; - eputs ("r0="); eputs (itoa (r0)); eputs ("\n"); @@ -1687,8 +1839,9 @@ simple_bload_env (SCM a) ///((internal)) #endif puts ("]: "); - // display_ (r2); - // puts ("\n"); + display_ (r2); + //stderr_ (r2); + puts ("\n"); return r2; } @@ -1759,12 +1912,13 @@ main (int argc, char *argv[]) if (argc > 1 && !strcmp (argv[1], "--dump")) return dump (); #endif + //if (r2 != 10) r2 = CAR (r2); push_cc (r2, cell_unspecified, r0, cell_unspecified); #if __GNUC__ - puts ("stack: "); - display_ (g_stack); - puts ("\n"); + // puts ("stack: "); + // display_ (g_stack); + // puts ("\n"); puts ("g_free="); puts (itoa(g_free)); @@ -1791,11 +1945,32 @@ main (int argc, char *argv[]) puts ("\n"); #endif - r3 = cell_vm_begin; - //r3 = cell_vm_apply; +#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 (); - stderr_ (r1); - //display_ (r1); +#else + r3 = cell_vm_begin; + 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); eputs ("\n"); #if !MES_MINI diff --git a/scaffold/tiny-mes.c b/scaffold/tiny-mes.c index 956380a7..b7591a6e 100644 --- a/scaffold/tiny-mes.c +++ b/scaffold/tiny-mes.c @@ -253,7 +253,7 @@ SCM r2 = 0; // save 2+load/dump SCM r3 = 0; // continuation #if __NYACC__ || FIXME_NYACC -enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; +enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; #else enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART}; #endif @@ -393,7 +393,7 @@ display_ (SCM x) putchar (VALUE (x)); break; } - case FUNCTION: + case TFUNCTION: { //puts ("\n"); if (VALUE (x) == 0) @@ -410,7 +410,7 @@ display_ (SCM x) { //puts ("\n"); #if __GNUC__ - putchar (48 + VALUE (x)); + puts (itoa (VALUE (x))); #else int i; i = VALUE (x); @@ -443,10 +443,65 @@ display_ (SCM x) puts (")"); break; } + case SPECIAL: + { + switch (x) + { + case 1: {puts ("()"); break;} + case 2: {puts ("#f"); break;} + case 3: {puts ("#t"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } + case SYMBOL: + { + switch (x) + { + case 11: {puts (" . "); break;} + case 12: {puts ("lambda"); break;} + case 13: {puts ("begin"); break;} + case 14: {puts ("if"); break;} + case 15: {puts ("quote"); break;} + case 37: {puts ("car"); break;} + case 38: {puts ("cdr"); break;} + case 39: {puts ("null?"); break;} + case 40: {puts ("eq?"); break;} + case 41: {puts ("cons"); break;} + default: + { +#if __GNUC__ + puts (""); +#else + puts (""); +#endif + } + } + break; + } default: { //puts ("\n"); +#if __GNUC__ + puts ("<"); + puts (itoa (TYPE (x))); + puts (":"); + puts (itoa (x)); + puts (">"); +#else puts ("_"); +#endif break; } } @@ -501,7 +556,8 @@ int main (int argc, char *argv[]) { fill (); - puts (g_cells); + char *p = arena; + puts (p); puts ("\n"); display_ (10); puts ("\n");