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

mescc: Compile all of mini-mes. 

* module/language/c99/compiler.mes (case->jump-info): Support single statement.
* module/mes/elf-util.mes (function-prefix): Workaround for reversed
  functions.  FIXME!
* module/mes/elf.mes:
* scaffold/mini-mes.c (type_t): Rename FUNCTION to TFUNCTION for Nyacc.
  Add missing symbols.
  (eval_apply): Uncomment most.
* scaffold/tiny-mes.c:
* scaffold/cons-mes.c: Remove cruft.
This commit is contained in:
Jan Nieuwenhuizen 2017-03-06 07:14:15 +01:00
parent 78e70f9024
commit dd52f580fb
8 changed files with 426 additions and 379 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
GNUmakefile
View File

@ -118,6 +118,11 @@ mini-mes: scaffold/mini-mes.c GNUmakefile
gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $< gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<
chmod +x $@ chmod +x $@
# mini-mes: doc/examples/mini-mes.c GNUmakefile
# rm -f $@
# gcc -nostdlib --std=gnu99 -g -o $@ '-DVERSION="0.4"' $<
# chmod +x $@
cons-mes: scaffold/cons-mes.c GNUmakefile cons-mes: scaffold/cons-mes.c GNUmakefile
rm -f $@ rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $< gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<

27
lib.c
View File

@ -127,12 +127,37 @@ check_apply (SCM f, SCM e)
return cell_unspecified; return cell_unspecified;
} }
char const*
itoa (int x)
{
static char buf[10];
char *p = buf+9;
*p-- = 0;
int sign = x < 0;
if (sign)
x = -x;
do
{
*p-- = '0' + (x % 10);
x = x / 10;
} while (x);
if (sign)
*p-- = '-';
return p+1;
}
FILE *g_stdin; FILE *g_stdin;
int int
dump () dump ()
{ {
r1 = g_symbols; r1 = g_symbols;
gc (gc_push_frame ()); gc_push_frame ();
gc ();
gc_peek_frame ();
char *p = (char*)g_cells; char *p = (char*)g_cells;
fputc ('M', stdout); fputc ('M', stdout);
fputc ('E', stdout); fputc ('E', stdout);

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

@ -879,6 +879,16 @@
(let loop ((elements elements) (info info)) (let loop ((elements elements) (info info))
(if (null? elements) info (if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements)))))))) (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
((case (p-expr (ident ,constant)) ,statement)
((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
((case (p-expr (fixed ,value)) ,statement)
((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
((default ,statement)
((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
(_ (stderr "no case match: ~a\n" o) barf) (_ (stderr "no case match: ~a\n" o) barf)
))) )))

8
module/mes/elf-util.mes
View File

@ -74,7 +74,11 @@
;; ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels))))))) ;; ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels)))))))
(define (function-prefix name functions) (define (function-prefix name functions)
(member name (reverse functions) (lambda (a b) (equal? (car b) name)))) ;; FIXME
;;(member name (reverse functions) (lambda (a b) (equal? (car b) name)))
(let* ((x functions)
(x (if (and (pair? x) (equal? (caar x) "exit")) (reverse x) x)))
(member name x (lambda (a b) (equal? (car b) name)))))
(define function-offset (define function-offset
(let ((cache '())) (let ((cache '()))
@ -83,7 +87,7 @@
(let* ((prefix (function-prefix name functions)) (let* ((prefix (function-prefix name functions))
(offset (if prefix (length (functions->text (cdr prefix) '() 0 0 0)) (offset (if prefix (length (functions->text (cdr prefix) '() 0 0 0))
0))) 0)))
(if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset))) (if (and prefix (or (equal? name "exit") (> offset 0))) (set! cache (assoc-set! cache name offset)))
offset))))) offset)))))
(define (label-offset function label functions) (define (label-offset function label functions)

71
scaffold/cons-mes.c
View File

@ -424,10 +424,7 @@ SCM cell_cdr;
SCM SCM
alloc (int n) alloc (int n)
{ {
#if __GNUC__
//FIXME GNUC
assert (g_free + n < ARENA_SIZE); assert (g_free + n < ARENA_SIZE);
#endif
SCM x = g_free; SCM x = g_free;
g_free += n; g_free += n;
return x; return x;
@ -437,10 +434,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 __GNUC__
//FIXME GNUC
assert (TYPE (type) == NUMBER); assert (TYPE (type) == NUMBER);
#endif
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);
@ -517,19 +511,6 @@ cdr (SCM x)
return CDR(x); return CDR(x);
} }
// SCM
// eq_p (SCM x, SCM y)
// {
// return (x == y
// || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
// && STRING (x) == STRING (y)))
// || (TYPE (x) == CHAR && TYPE (y) == CHAR
// && VALUE (x) == VALUE (y))
// || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
// && VALUE (x) == VALUE (y)))
// ? cell_t : cell_f;
// }
SCM SCM
gc_push_frame () gc_push_frame ()
{ {
@ -568,30 +549,6 @@ assq (SCM x, SCM a)
return a != cell_nil ? car (a) : cell_f; return a != cell_nil ? car (a) : cell_f;
} }
#if __GNUC__
//FIXME GNUC
SCM
assq_ref_env (SCM x, SCM a)
{
x = assq (x, a);
if (x == cell_f) return cell_undefined;
return cdr (x);
}
#endif
#if __GNUC__
//FIXME GNUC
SCM
assert_defined (SCM x, SCM e)
{
if (e != cell_undefined) return e;
// error (cell_symbol_unbound_variable, x);
puts ("unbound variable");
exit (33);
return e;
}
#endif
SCM SCM
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
{ {
@ -606,22 +563,10 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
return cell_unspecified; return cell_unspecified;
} }
#if __GNUC__
SCM caar (SCM x) {return car (car (x));} SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));} SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));} SCM cdar (SCM x) {return cdr (car (x));}
SCM cddr (SCM x) {return cdr (cdr (x));} SCM cddr (SCM x) {return cdr (cdr (x));}
#else
// Weirdness: wrong function labeling
// SCM cadr (SCM x) {
// x = cdr (x);
// return car (x);
// }
// SCM cddr (SCM x) {
// x = cdr (x);
// return cdr (x);
// }
#endif
#if __GNUC__ #if __GNUC__
//FIXME //FIXME
@ -681,8 +626,7 @@ call (SCM fn, SCM x)
// case -1: return FUNCTION (fn).functionn (x); // case -1: return FUNCTION (fn).functionn (x);
case 0: {return (FUNCTION (fn).function) ();} case 0: {return (FUNCTION (fn).function) ();}
case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
//case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), car (cdr (x)));}
case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
#if __GNUC__ #if __GNUC__
// FIXME GNUC // FIXME GNUC
@ -690,7 +634,6 @@ call (SCM fn, SCM x)
#endif #endif
default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
} }
return cell_unspecified; return cell_unspecified;
} }
@ -1274,11 +1217,7 @@ stderr_ (SCM x)
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
puts ("Hello mini-mes!\n"); puts ("Hello cons-mes!\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"); if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
#if __GNUC__ #if __GNUC__
if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);}; if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
@ -1305,10 +1244,6 @@ main (int argc, char *argv[])
push_cc (r2, cell_unspecified, r0, cell_unspecified); push_cc (r2, cell_unspecified, r0, cell_unspecified);
// puts ("g_stack: ");
// display_ (g_stack);
// puts ("\n");
#if __GNUC__ #if __GNUC__
puts ("g_free="); puts ("g_free=");
@ -1336,10 +1271,8 @@ main (int argc, char *argv[])
puts ("\n"); puts ("\n");
#endif #endif
//r3 = cell_vm_begin;
r3 = cell_vm_apply; r3 = cell_vm_apply;
r1 = eval_apply (); r1 = eval_apply ();
//stderr_ (r1);
display_ (r1); display_ (r1);
eputs ("\n"); eputs ("\n");

665
scaffold/mini-mes.c
View File

@ -32,8 +32,8 @@
#define NYACC_CDR nyacc_cdr #define NYACC_CDR nyacc_cdr
#endif #endif
char arena[2000]; int ARENA_SIZE = 200000;
//char buf0[400]; char arena[200000];
int g_stdin = 0; int g_stdin = 0;
@ -101,13 +101,23 @@ open (char const *s, int mode)
return r; return r;
} }
int puts (char const*);
char const* itoa (int);
int int
getchar () getchar ()
{ {
char c; char c;
int r = read (g_stdin, &c, 1); int r = read (g_stdin, &c, 1);
if (r < 1) return -1; if (r < 1) return -1;
return c; int i = c;
if (i < 0) {
puts ("urg=");
puts (itoa (i));
puts ("\n");
}
if (i < 0) i += 256;
return i;
} }
void void
@ -246,6 +256,7 @@ int g_debug = 0;
int g_free = 0; int g_free = 0;
SCM g_continuations = 0;
SCM g_symbols = 0; SCM g_symbols = 0;
SCM g_stack = 0; SCM g_stack = 0;
// a/env // a/env
@ -258,7 +269,7 @@ SCM r2 = 0;
SCM r3 = 0; SCM r3 = 0;
#if __NYACC__ || FIXME_NYACC #if __NYACC__ || FIXME_NYACC
enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; enum type_t {CHAR, TCLOSURE, TCONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
#else #else
enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART}; enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
#endif #endif
@ -319,23 +330,46 @@ struct scm *g_cells = arena;
#define cell_symbol_if 14 #define cell_symbol_if 14
#define cell_symbol_quote 15 #define cell_symbol_quote 15
#define cell_symbol_set_x 16 #define cell_symbol_set_x 16
#define cell_symbol_sc_expand 17
#define cell_symbol_macro_expand 18
#define cell_symbol_sc_expander_alist 19
#define cell_symbol_call_with_values 20
#define cell_call_with_current_continuation 21
#define cell_symbol_call_with_current_continuation 22
#define cell_symbol_current_module 23
#define cell_symbol_primitive_load 24
#define cell_symbol_read_input_file 25
#define cell_vm_evlis 42
#define cell_vm_evlis2 43
#define cell_vm_evlis3 44
#define cell_vm_apply 45 #define cell_vm_apply 45
#define cell_vm_apply2 46 #define cell_vm_apply2 46
#define cell_vm_eval 47 #define cell_vm_eval 47
#define cell_vm_eval_car 48
#define cell_vm_eval_cdr 49
#define cell_vm_eval_cons 50
#define cell_vm_eval_null_p 51
#define cell_vm_eval_set_x 52
#define cell_vm_eval_macro 53
#define cell_vm_eval2 54
#define cell_vm_macro_expand 55
#define cell_vm_begin 56 #define cell_vm_begin 56
//#define cell_vm_begin_read_input_file 57 #define cell_vm_begin_read_input_file 57
#define cell_vm_begin2 58 #define cell_vm_begin2 58
#define cell_vm_if 59
#define cell_vm_if_expr 60
#define cell_vm_call_with_values2 61
#define cell_vm_call_with_current_continuation2 62
#define cell_vm_return 63 #define cell_vm_return 63
#define cell_test 64
SCM tmp; SCM tmp;
SCM tmp_num; SCM tmp_num;
SCM tmp_num2; SCM tmp_num2;
int ARENA_SIZE = 200;
struct function g_functions[5]; struct function g_functions[5];
int g_function = 0; int g_function = 0;
@ -388,9 +422,7 @@ SCM cell_cdr;
#define STRING(x) g_cells[x].car #define STRING(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr #define CDR(x) g_cells[x].cdr
#if __GNUC__ #define CLOSURE(x) g_cells[x].cdr
//#define CLOSURE(x) g_cells[x].closure
#endif
#define CONTINUATION(x) g_cells[x].cdr #define CONTINUATION(x) g_cells[x].cdr
#if __GNUC__ #if __GNUC__
//#define FUNCTION(x) g_functions[g_cells[x].function] //#define FUNCTION(x) g_functions[g_cells[x].function]
@ -401,7 +433,7 @@ SCM cell_cdr;
#define VECTOR(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr
#define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n)) #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
//#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack) #define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack)
#define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n)) #define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
//#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0) //#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
@ -409,7 +441,7 @@ SCM cell_cdr;
#define CAAR(x) CAR (CAR (x)) #define CAAR(x) CAR (CAR (x))
// #define CDAR(x) CDR (CAR (x)) // #define CDAR(x) CDR (CAR (x))
#define CADAR(x) CAR (CDR (CAR (x))) #define CADAR(x) CAR (CDR (CAR (x)))
// #define CADDR(x) CAR (CDR (CDR (x))) #define CADDR(x) CAR (CDR (CDR (x)))
// #define CDDDR(x) CDR (CDR (CDR (x))) // #define CDDDR(x) CDR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CADR(x) CAR (CDR (x)) #define CADR(x) CAR (CDR (x))
@ -424,10 +456,7 @@ SCM cell_cdr;
SCM SCM
alloc (int n) alloc (int n)
{ {
#if __GNUC__
//FIXME GNUC
assert (g_free + n < ARENA_SIZE); assert (g_free + n < ARENA_SIZE);
#endif
SCM x = g_free; SCM x = g_free;
g_free += n; g_free += n;
return x; return x;
@ -438,9 +467,14 @@ make_cell (SCM type, SCM car, SCM cdr)
{ {
SCM x = alloc (1); SCM x = alloc (1);
#if __GNUC__ #if __GNUC__
//FIXME GNUC puts ("make_cell type=");
assert (TYPE (type) == NUMBER); puts (itoa (type));
puts ("\n");
puts ("make_cell type.type=");
puts (itoa (TYPE (type)));
puts ("\n");
#endif #endif
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);
@ -530,6 +564,16 @@ cdr (SCM x)
// ? cell_t : cell_f; // ? cell_t : cell_f;
// } // }
SCM
assert_defined (SCM x, SCM e)
{
if (e != cell_undefined) return e;
// error (cell_symbol_unbound_variable, x);
puts ("unbound variable");
exit (33);
return e;
}
SCM SCM
gc_push_frame () gc_push_frame ()
{ {
@ -568,8 +612,6 @@ assq (SCM x, SCM a)
return a != cell_nil ? car (a) : cell_f; return a != cell_nil ? car (a) : cell_f;
} }
#if __GNUC__
//FIXME GNUC
SCM SCM
assq_ref_env (SCM x, SCM a) assq_ref_env (SCM x, SCM a)
{ {
@ -577,20 +619,39 @@ assq_ref_env (SCM x, SCM a)
if (x == cell_f) return cell_undefined; if (x == cell_f) return cell_undefined;
return cdr (x); return cdr (x);
} }
#endif
#if __GNUC__
//FIXME GNUC
SCM SCM
assert_defined (SCM x, SCM e) set_car_x (SCM x, SCM e)
{ {
if (e != cell_undefined) return e; assert (TYPE (x) == PAIR);
// error (cell_symbol_unbound_variable, x); CAR (x) = e;
puts ("unbound variable"); return cell_unspecified;
exit (33); }
return e;
SCM
set_cdr_x (SCM x, SCM e)
{
//if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
CDR (x) = e;
return cell_unspecified;
}
SCM
set_env_x (SCM x, SCM e, SCM a)
{
SCM p = assert_defined (x, assq (x, a));
//if (TYPE (p) != PAIR) error (cell_symbol_not_a_pair, cons (p, x));
return set_cdr_x (p, e);
}
SCM
call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
{
SCM cl = cons (cons (cell_closure, x), x);
r1 = e;
r0 = cl;
return cell_unspecified;
} }
#endif
SCM SCM
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
@ -606,24 +667,14 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
return cell_unspecified; return cell_unspecified;
} }
#if __GNUC__
SCM caar (SCM x) {return car (car (x));} SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));} SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));} SCM cdar (SCM x) {return cdr (car (x));}
SCM cddr (SCM x) {return cdr (cdr (x));} SCM cddr (SCM x) {return cdr (cdr (x));}
#else
SCM cadr (SCM x) {
x = cdr (x);
return car (x);
}
SCM cddr (SCM x) {
x = cdr (x);
return cdr (x);
}
#endif
#if __GNUC__ #if __GNUC__
//FIXME //FIXME
SCM make_closure (SCM,SCM,SCM);
SCM call (SCM,SCM); SCM call (SCM,SCM);
SCM gc_pop_frame (); SCM gc_pop_frame ();
#endif #endif
@ -643,15 +694,12 @@ eval_apply ()
switch (r3) switch (r3)
{ {
#if 0
case cell_vm_evlis: goto evlis; case cell_vm_evlis: goto evlis;
case cell_vm_evlis2: goto evlis2; case cell_vm_evlis2: goto evlis2;
case cell_vm_evlis3: goto evlis3; case cell_vm_evlis3: goto evlis3;
#endif case cell_vm_apply: goto apply;
case cell_vm_apply: {goto apply;} case cell_vm_apply2: goto apply2;
case cell_vm_apply2: {goto apply2;} case cell_vm_eval: goto eval;
case cell_vm_eval: {goto eval;}
#if 0
#if FIXED_PRIMITIVES #if FIXED_PRIMITIVES
case cell_vm_eval_car: goto eval_car; case cell_vm_eval_car: goto eval_car;
case cell_vm_eval_cdr: goto eval_cdr; case cell_vm_eval_cdr: goto eval_cdr;
@ -662,39 +710,31 @@ eval_apply ()
case cell_vm_eval_macro: goto eval_macro; case cell_vm_eval_macro: goto eval_macro;
case cell_vm_eval2: goto eval2; case cell_vm_eval2: goto eval2;
case cell_vm_macro_expand: goto macro_expand; case cell_vm_macro_expand: goto macro_expand;
#endif case cell_vm_begin: goto begin;
case cell_vm_begin: {goto begin;}
///case cell_vm_begin_read_input_file: goto begin_read_input_file; ///case cell_vm_begin_read_input_file: goto begin_read_input_file;
case cell_vm_begin2: {goto begin2;} case cell_vm_begin2: goto begin2;
#if 0
case cell_vm_if: goto vm_if; case cell_vm_if: goto vm_if;
case cell_vm_if_expr: goto if_expr; case cell_vm_if_expr: goto if_expr;
case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2; case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
case cell_vm_call_with_values2: goto call_with_values2; case cell_vm_call_with_values2: goto call_with_values2;
case cell_vm_return: goto vm_return; case cell_vm_return: goto vm_return;
#endif case cell_unspecified: return r1;
case cell_unspecified: {return r1;} default: assert (0);
#if __GNUC__
//FIXME GNUC
default: {assert (0);}
#endif
} }
SCM x = cell_nil; SCM x = cell_nil;
SCM y = cell_nil; SCM y = cell_nil;
// #if 0 evlis:
// evlis: 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); goto eval;
// goto eval; evlis2:
// evlis2: push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
// push_cc (cdr (r2), r1, r0, cell_vm_evlis3); goto evlis;
// goto evlis; evlis3:
// evlis3: r1 = cons (r2, r1);
// r1 = cons (r2, r1); goto vm_return;
// goto vm_return;
// #endif
apply: apply:
puts ("apply\n"); puts ("apply\n");
@ -705,84 +745,79 @@ eval_apply ()
r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
goto vm_return; goto vm_return;
} }
// case CLOSURE: case TCLOSURE:
// { {
// SCM cl = CLOSURE (car (r1)); SCM cl = CLOSURE (car (r1));
// SCM formals = cadr (cl); SCM formals = cadr (cl);
// SCM body = cddr (cl); SCM body = cddr (cl);
// SCM aa = cdar (cl); SCM aa = cdar (cl);
// aa = cdr (aa); aa = cdr (aa);
// //check_formals (car (r1), formals, cdr (r1)); //check_formals (car (r1), formals, cdr (r1));
// SCM p = pairlis (formals, cdr (r1), aa); SCM p = pairlis (formals, cdr (r1), aa);
// call_lambda (body, p, aa, r0); call_lambda (body, p, aa, r0);
// goto begin; goto begin;
// } }
// case CONTINUATION: case TCONTINUATION:
// { {
// x = r1; x = r1;
// g_stack = CONTINUATION (CAR (r1)); g_stack = CONTINUATION (CAR (r1));
// gc_pop_frame (); gc_pop_frame ();
// r1 = cadr (x); r1 = cadr (x);
// goto eval_apply; goto eval_apply;
// } }
// #if 0 case SPECIAL:
// case SPECIAL: {
// { switch (car (r1))
// switch (car (r1)) {
// { case cell_vm_apply:
// case cell_vm_apply: {
// { push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
// push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return); goto apply;
// goto apply; }
// } case cell_vm_eval:
// case cell_vm_eval: {
// { push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
// push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return); goto eval;
// goto eval; }
// } case cell_call_with_current_continuation:
// case cell_call_with_current_continuation: {
// { r1 = cdr (r1);
// r1 = cdr (r1); goto call_with_current_continuation;
// goto call_with_current_continuation; }
// } //default: check_apply (cell_f, car (r1));
// default: check_apply (cell_f, car (r1)); }
// } }
// } case SYMBOL:
// case SYMBOL: {
// { if (car (r1) == cell_symbol_call_with_values)
// if (car (r1) == cell_symbol_call_with_values) {
// { r1 = cdr (r1);
// r1 = cdr (r1); goto call_with_values;
// goto call_with_values; }
// } if (car (r1) == cell_symbol_current_module)
// if (car (r1) == cell_symbol_current_module) {
// { r1 = r0;
// r1 = r0; goto vm_return;
// goto vm_return; }
// } break;
// break; }
// } case PAIR:
// #endif {
// case PAIR: switch (caar (r1))
// { {
// switch (caar (r1)) case cell_symbol_lambda:
// { {
// case cell_symbol_lambda: SCM formals = cadr (car (r1));
// { SCM body = cddr (car (r1));
// SCM formals = cadr (car (r1)); SCM p = pairlis (formals, cdr (r1), r0);
// SCM body = cddr (car (r1)); //check_formals (r1, formals, cdr (r1));
// SCM p = pairlis (formals, cdr (r1), r0); call_lambda (body, p, p, r0);
// check_formals (r1, formals, cdr (r1)); goto begin;
// call_lambda (body, p, p, r0); }
// goto begin; }
// } }
// }
// }
} }
#if __GNUC__
//FIXME
push_cc (car (r1), r1, r0, cell_vm_apply2); push_cc (car (r1), r1, r0, cell_vm_apply2);
#endif
goto eval; goto eval;
apply2: apply2:
//check_apply (r1, car (r2)); //check_apply (r1, car (r2));
@ -796,64 +831,61 @@ eval_apply ()
{ {
switch (car (r1)) switch (car (r1))
{ {
// #if FIXED_PRIMITIVES #if FIXED_PRIMITIVES
// case cell_symbol_car: case cell_symbol_car:
// { {
// push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval; push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
// eval_car: eval_car:
// x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply; x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
// } }
// case cell_symbol_cdr: case cell_symbol_cdr:
// { {
// push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval; push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
// eval_cdr: eval_cdr:
// x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply; x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
// } }
// case cell_symbol_cons: { case cell_symbol_cons: {
// push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis; push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
// eval_cons: eval_cons:
// x = r1; x = r1;
// gc_pop_frame (); gc_pop_frame ();
// r1 = cons (CAR (x), CADR (x)); r1 = cons (CAR (x), CADR (x));
// goto eval_apply; goto eval_apply;
// } }
// case cell_symbol_null_p: case cell_symbol_null_p:
// { {
// push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p); push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
// goto eval; goto eval;
// eval_null_p: eval_null_p:
// x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply; x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
// } }
// #endif // FIXED_PRIMITIVES #endif // FIXED_PRIMITIVES
// case cell_symbol_quote: case cell_symbol_quote:
// { {
// x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply; x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply;
// } }
// case cell_symbol_begin: goto begin; case cell_symbol_begin: goto begin;
// case cell_symbol_lambda: case cell_symbol_lambda:
// { {
// r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0)); r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
// goto vm_return; goto vm_return;
// } }
// #if 0 case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
// case cell_symbol_if: {r1=cdr (r1); goto vm_if;} case cell_symbol_set_x:
// case cell_symbol_set_x: {
// { push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x);
// push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x); goto eval;
// goto eval; eval_set_x:
// eval_set_x: x = r2;
// x = r2; r1 = set_env_x (cadr (x), r1, r0);
// r1 = set_env_x (cadr (x), r1, r0); goto vm_return;
// goto vm_return; }
// } case cell_vm_macro_expand:
// case cell_vm_macro_expand: {
// { push_cc (cadr (r1), r1, r0, cell_vm_return);
// push_cc (cadr (r1), r1, r0, cell_vm_return); goto macro_expand;
// goto macro_expand; }
// }
// #endif
default: { default: {
#if 0
push_cc (r1, r1, r0, cell_vm_eval_macro); push_cc (r1, r1, r0, cell_vm_eval_macro);
goto macro_expand; goto macro_expand;
eval_macro: eval_macro:
@ -869,7 +901,6 @@ eval_apply ()
} }
push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis; push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis;
eval2: eval2:
#endif
r1 = cons (car (r2), r1); r1 = cons (car (r2), r1);
goto apply; goto apply;
} }
@ -883,30 +914,30 @@ eval_apply ()
default: {goto vm_return;} default: {goto vm_return;}
} }
// SCM macro; SCM macro;
// SCM expanders; SCM expanders;
// #if 0 macro_expand:
// macro_expand: #if 0
// if (TYPE (r1) == PAIR if (TYPE (r1) == PAIR
// && (macro = lookup_macro (car (r1), r0)) != cell_f) && (macro = lookup_macro (car (r1), r0)) != cell_f) // FIXME GNUC
// { {
// r1 = cons (macro, CDR (r1)); r1 = cons (macro, CDR (r1));
// goto apply; goto apply;
// } }
// else if (TYPE (r1) == PAIR else if (TYPE (r1) == PAIR
// && TYPE (CAR (r1)) == SYMBOL && TYPE (CAR (r1)) == SYMBOL
// && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
// && ((macro = assq (CAR (r1), expanders)) != cell_f)) && ((macro = assq (CAR (r1), expanders)) != cell_f))
// { {
// SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
// if (sc_expand != cell_undefined && sc_expand != cell_f) if (sc_expand != cell_undefined && sc_expand != cell_f)
// { {
// r1 = cons (sc_expand, cons (r1, cell_nil)); r1 = cons (sc_expand, cons (r1, cell_nil));
// goto apply; goto apply;
// } }
// } }
// goto vm_return; goto vm_return;
// #endif #endif
begin: begin:
x = cell_unspecified; x = cell_unspecified;
while (r1 != cell_nil) { while (r1 != cell_nil) {
@ -914,7 +945,6 @@ eval_apply ()
{ {
if (caar (r1) == cell_symbol_begin) if (caar (r1) == cell_symbol_begin)
r1 = append2 (cdar (r1), cdr (r1)); r1 = append2 (cdar (r1), cdr (r1));
#if 0
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);
@ -922,17 +952,13 @@ eval_apply ()
begin_read_input_file: begin_read_input_file:
r1 = append2 (r1, cdr (r2)); r1 = append2 (r1, cdr (r2));
} }
#endif
} }
if (CDR (r1) == cell_nil) if (CDR (r1) == cell_nil)
{ {
r1 = car (r1); r1 = car (r1);
goto eval; goto eval;
} }
#if __GNUC__
//FIXME
push_cc (CAR (r1), r1, r0, cell_vm_begin2); push_cc (CAR (r1), r1, r0, cell_vm_begin2);
#endif
goto eval; goto eval;
begin2: begin2:
x = r1; x = r1;
@ -941,45 +967,49 @@ eval_apply ()
r1 = x; r1 = x;
goto vm_return; goto vm_return;
// #if 0 vm_if:
// vm_if: push_cc (car (r1), r1, r0, cell_vm_if_expr);
// push_cc (car (r1), r1, r0, cell_vm_if_expr); goto eval;
// goto eval; if_expr:
// if_expr: x = r1;
// x = r1; r1 = r2;
// r1 = r2; if (x != cell_f)
// if (x != cell_f) {
// { r1 = cadr (r1);
// r1 = cadr (r1); goto eval;
// goto eval; }
// } if (cddr (r1) != cell_nil)
// if (cddr (r1) != cell_nil) {
// { r1 = car (cddr (r1));
// r1 = car (cddr (r1)); goto eval;
// goto eval; }
// } r1 = cell_unspecified;
// r1 = cell_unspecified; goto vm_return;
// goto vm_return;
// call_with_current_continuation: call_with_current_continuation:
// gc_push_frame (); gc_push_frame ();
// x = MAKE_CONTINUATION (g_continuations++); #if __GNUC__
// gc_pop_frame (); // FIXME GCC
// push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2); x = MAKE_CONTINUATION (g_continuations++);
// goto apply; #else
// call_with_current_continuation2: x = MAKE_CONTINUATION (g_continuations);
// CONTINUATION (r2) = g_stack; g_continuations++;
// goto vm_return; #endif
gc_pop_frame ();
push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
goto apply;
call_with_current_continuation2:
CONTINUATION (r2) = g_stack;
goto vm_return;
// call_with_values: call_with_values:
// push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2); push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
// goto apply; goto apply;
// call_with_values2: call_with_values2:
// if (TYPE (r1) == VALUES) if (TYPE (r1) == VALUES)
// r1 = CDR (r1); r1 = CDR (r1);
// r1 = cons (cadr (r2), r1); r1 = cons (cadr (r2), r1);
// goto apply; goto apply;
// #endif
vm_return: vm_return:
x = r1; x = r1;
@ -1007,8 +1037,7 @@ call (SCM fn, SCM x)
// case -1: return FUNCTION (fn).functionn (x); // case -1: return FUNCTION (fn).functionn (x);
case 0: {return (FUNCTION (fn).function) ();} case 0: {return (FUNCTION (fn).function) ();}
case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
//case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), car (cdr (x)));}
case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
#if __GNUC__ #if __GNUC__
// FIXME GNUC // FIXME GNUC
@ -1203,6 +1232,10 @@ g_free = 62;
g_free++; g_free++;
// g_cells[cell_vm_return] = scm_vm_return; // g_cells[cell_vm_return] = scm_vm_return;
g_free = 63;
g_free++;
//g_cells[cell_test] = scm_test;
#endif #endif
g_symbol_max = g_free; g_symbol_max = g_free;
@ -1245,7 +1278,7 @@ g_free++;
SCM SCM
make_closure (SCM args, SCM body, SCM a) make_closure (SCM args, SCM body, SCM a)
{ {
return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); return make_cell (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
} }
SCM SCM
@ -1511,12 +1544,18 @@ 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"; char *mo = "module/mes/hack-32.mo";
//char *mo = "cons-32.mo"; #else
char *mo = "cons-32.mo";
#endif
puts (mo); puts (mo);
puts ("\n"); puts ("\n");
g_stdin = open (mo, 0); g_stdin = open (mo, 0);
@ -1544,26 +1583,72 @@ simple_bload_env (SCM a) ///((internal))
puts ("\n"); puts ("\n");
#endif #endif
// #if !CONS
// //FIXME: skip one cell
// for (int q=0; q < 12; q++)
// getchar ();
// #endif
int i = 0;
c = getchar (); c = getchar ();
while (c != -1) while (c != -1)
{ {
#if __GNUC__
puts ("\ni=");
puts (itoa (i));
puts (" ");
puts (itoa (c));
puts (" ");
#endif
putchar (c);
i++;
*p++ = c; *p++ = c;
c = getchar (); c = getchar ();
putchar (c);
} }
puts ("read done\n"); puts ("read done\n");
g_free = (p-(char*)g_cells) / sizeof (struct scm); g_free = (p-(char*)g_cells) / sizeof (struct scm);
#if 0 #if !CONS
gc_peek_frame (); gc_peek_frame ();
#endif
// URG
// r0 = 628;
// r1 = 67;
// r2 = 389;
#if __GNUC__
puts ("XXcells read: ");
puts (itoa (g_free));
puts ("\n");
g_symbols = r1; g_symbols = r1;
#else
eputs ("r0=");
eputs (itoa (r0));
eputs ("\n");
eputs ("r1=");
eputs (itoa (r1));
eputs ("\n");
eputs ("r2=");
eputs (itoa (r2));
eputs ("\n");
eputs ("g_stack=");
eputs (itoa (g_stack));
eputs ("\n");
#endif
#if CONS
if (g_free != 15) exit (33); if (g_free != 15) exit (33);
g_symbols = 1; g_symbols = 1;
r2 = 10; r2 = 10;
#endif #endif
g_stdin = STDIN; g_stdin = STDIN;
r0 = mes_builtins (r0); r0 = mes_builtins (r0);
@ -1581,11 +1666,9 @@ simple_bload_env (SCM a) ///((internal))
puts ("r2: "); puts ("r2: ");
puts (itoa (r2)); puts (itoa (r2));
puts ("\n"); puts ("\n");
// display_ (g_symbols);
// puts ("\n");
#endif #endif
#if CONS
display_ (r2); display_ (r2);
puts ("\n"); puts ("\n");
@ -1595,18 +1678,18 @@ simple_bload_env (SCM a) ///((internal))
if (TYPE (12) != PAIR) if (TYPE (12) != PAIR)
exit (33); exit (33);
r0 = 1;
#endif
puts ("program["); puts ("program[");
#if __GNUC__ #if __GNUC__
puts (itoa (r2)); puts (itoa (r2));
#endif #endif
puts ("]: "); puts ("]: ");
display_ (r2); // display_ (r2);
//display_ (14); // puts ("\n");
puts ("\n");
r0 = 1;
//r2 = 10;
return r2; return r2;
} }
@ -1679,7 +1762,9 @@ main (int argc, char *argv[])
push_cc (r2, cell_unspecified, r0, cell_unspecified); push_cc (r2, cell_unspecified, r0, cell_unspecified);
#if __GNUC__ #if __GNUC__
puts ("stack: ");
display_ (g_stack); display_ (g_stack);
puts ("\n");
puts ("g_free="); puts ("g_free=");
puts (itoa(g_free)); puts (itoa(g_free));
@ -1706,11 +1791,11 @@ main (int argc, char *argv[])
puts ("\n"); puts ("\n");
#endif #endif
//r3 = cell_vm_begin; r3 = cell_vm_begin;
r3 = cell_vm_apply; //r3 = cell_vm_apply;
r1 = eval_apply (); r1 = eval_apply ();
//stderr_ (r1); stderr_ (r1);
display_ (r1); //display_ (r1);
eputs ("\n"); eputs ("\n");
#if !MES_MINI #if !MES_MINI

15
scaffold/tiny-mes.c
View File

@ -484,22 +484,14 @@ bload_env (SCM a) ///((internal))
getchar (); getchar ();
c = getchar (); c = getchar ();
// int i = 0;
while (c != -1) while (c != -1)
{ {
*p++ = c; *p++ = c;
//g_cells[i] = c;
// i++;
c = getchar (); c = getchar ();
//puts ("\nc:");
//putchar (c);
} }
puts ("read done\n"); puts ("read done\n");
display_ (10); display_ (10);
// puts ("\n");
// fill ();
// display_ (10);
puts ("\n"); puts ("\n");
return r2; return r2;
@ -508,16 +500,9 @@ bload_env (SCM a) ///((internal))
int int
main (int argc, char *argv[]) main (int argc, char *argv[])
{ {
// 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 (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
// puts ("Hello tiny-mes!\n");
fill (); fill ();
puts (g_cells); puts (g_cells);
puts ("\n"); puts ("\n");
// return 22;
display_ (10); display_ (10);
puts ("\n"); puts ("\n");
SCM program = bload_env (r0); SCM program = bload_env (r0);