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

core: Make symbols constants.

Browse source 
* mes.c (apply_env,eval_env): Rewrite using switch.
* build-aux/mes-snarf.scm (symbol->header): Define constants.
  (symbol->source): Only update g_free and init cells.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-14 19:02:19 +01:00
parent dd1daf92e4
commit 94d1c65bde
2 changed files with 84 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
build-aux/mes-snarf.scm
View file

@ -72,11 +72,11 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(define %start 1)
(define (symbol->header s i)
(format #f "SCM cell_~a;\n" s))
(format #f "#define cell_~a ~a\n" s i))
(define (symbol->source s i)
(string-append
(format #f "cell_~a = g_free.value++;\n" s)
(format #f "g_free.value++;\n")
(format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
(define (function->header f i)

151
mes.c
View file

@ -43,7 +43,7 @@ int ARENA_SIZE = 100000;
int MAX_ARENA_SIZE = 20000000;
int GC_SAFETY = 100;
typedef long SCM;
typedef int SCM;
enum type_t {CHAR, FUNCTION, MACRO, NUMBER, PAIR, SPECIAL, STRING, SYMBOL, REF, VALUES, VECTOR, BROKEN_HEART};
typedef SCM (*function0_t) (void);
typedef SCM (*function1_t) (SCM);
@ -80,34 +80,6 @@ typedef struct scm_t {
};
} scm;
function functions[200];
int g_function = 0;
#include "mes.symbols.h"
#include "define.h"
#include "display.h"
#include "lib.h"
#include "math.h"
#include "mes.h"
#include "posix.h"
#include "quasiquote.h"
#include "reader.h"
#include "string.h"
#include "type.h"
SCM g_symbols = 0;
SCM stack = 0;
SCM r0 = 0; // a/env
SCM r1 = 0; // param 1
SCM r2 = 0; // param 2
SCM r3 = 0; // param 3
SCM tmp;
SCM tmp_num;
SCM tmp_num2;
SCM tmp_num3;
SCM tmp_num4;
scm scm_nil = {SPECIAL, "()"};
scm scm_f = {SPECIAL, "#f"};
scm scm_t = {SPECIAL, "#t"};
@ -170,6 +142,35 @@ scm g_free = {NUMBER, .value=0};
scm *g_cells;
scm *g_news = 0;
#include "mes.symbols.h"
SCM tmp;
SCM tmp_num;
SCM tmp_num2;
SCM tmp_num3;
SCM tmp_num4;
function functions[200];
int g_function = 0;
SCM g_symbols = 0;
SCM stack = 0;
SCM r0 = 0; // a/env
SCM r1 = 0; // param 1
SCM r2 = 0; // param 2
SCM r3 = 0; // param 3
#include "define.h"
#include "display.h"
#include "lib.h"
#include "math.h"
#include "mes.h"
#include "posix.h"
#include "quasiquote.h"
#include "reader.h"
#include "string.h"
#include "type.h"
#define CAR(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr
#define HITS(x) g_cells[x].hits
@ -378,13 +379,18 @@ vm_apply_env ()
return call_with_values_env (car (r2), cadr (r2), r0);
if (r1 == cell_symbol_current_module) return r0;
}
else if (car (r1) == cell_symbol_lambda) {
else
switch (car (r1))
{
case cell_symbol_lambda:
{
SCM args = cadr (r1);
SCM body = cddr (r1);
SCM p = pairlis (args, r2, r0);
return call_lambda (body, p, p, r0);
}
else if (car (r1) == cell_closure) {
case cell_closure:
{
SCM args = caddr (r1);
SCM body = cdddr (r1);
SCM aa = cdadr (r1);
@ -393,9 +399,10 @@ vm_apply_env ()
return call_lambda (body, p, aa, r0);
}
#if BOOT
else if (car (r1) == cell_symbol_label)
case cell_symbol_label:
return apply_env (caddr (r1), r2, cons (cons (cadr (r1), caddr (r1)), r0));
#endif
}
SCM e = eval_env (r1, r0);
char const* type = 0;
if (e == cell_f || e == cell_t) type = "bool";
@ -423,78 +430,49 @@ vm_eval_env ()
{
case PAIR:
{
switch (car (r1))
{
#if FIXED_PRIMITIVES
if (car (r1) == cell_symbol_car)
return car (eval_env (CADR (r1), r0));
if (car (r1) == cell_symbol_cdr)
return cdr (eval_env (CADR (r1), r0));
if (car (r1) == cell_symbol_cons) {
SCM m = evlis_env (CDR (r1), r0);
return cons (CAR (m), CADR (m));
}
if (car (r1) == cell_symbol_null_p)
return null_p (eval_env (CADR (r1), r0));
case cell_symbol_car: return car (eval_env (CADR (r1), r0));
case cell_symbol_cdr: return cdr (eval_env (CADR (r1), r0));
case cell_symbol_cons: {SCM m = evlis_env (CDR (r1), r0);
return cons (CAR (m), CADR (m));}
case cell_symbol_null_p: return null_p (eval_env (CADR (r1), r0));
#endif // FIXED_PRIMITIVES
if (car (r1) == cell_symbol_quote)
return cadr (r1);
case cell_symbol_quote: return cadr (r1);
#if QUASISYNTAX
if (car (r1) == cell_symbol_syntax)
return r1;
case cell_symbol_syntax: return r1;
#endif
if (car (r1) == cell_symbol_begin)
return begin_env (r1, r0);
if (car (r1) == cell_symbol_lambda)
case cell_symbol_begin: return begin_env (r1, r0);
case cell_symbol_lambda:
return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
if (car (r1) == cell_closure)
return r1;
if (car (r1) == cell_symbol_if)
return if_env (cdr (r1), r0);
case cell_closure: return r1;
case cell_symbol_if: return if_env (cdr (r1), r0);
#if !BOOT
if (car (r1) == cell_symbol_define)
return define_env (r1, r0);
if (car (r1) == cell_symbol_define_macro)
return define_env (r1, r0);
if (car (r1) == cell_symbol_primitive_load)
return begin_env (read_input_file_env (r0), r0);
#else
if (car (r1) == cell_symbol_define) {
fprintf (stderr, "C DEFINE: ");
display_ (stderr,
TYPE (cadr (r1)) == SYMBOL
? STRING (cadr (r1))
: STRING (caadr (r1)));
fprintf (stderr, "\n");
}
assert (car (r1) != cell_symbol_define);
assert (car (r1) != cell_symbol_define_macro);
case cell_symbol_define: return define_env (r1, r0);
case cell_symbol_define_macro: return define_env (r1, r0);
#endif
#if 1 //!BOOT
if (car (r1) == cell_symbol_set_x)
{
SCM x = eval_env (caddr (r1), r0);
return set_env_x (cadr (r1), x, r0);
case cell_symbol_set_x: {
SCM x = eval_env (caddr (r1), r0); return set_env_x (cadr (r1), x, r0);
}
#else
assert (car (r1) != cell_symbol_set_x);
#endif
#if QUASIQUOTE
if (car (r1) == cell_symbol_unquote)
return eval_env (cadr (r1), r0);
if (car (r1) == cell_symbol_quasiquote)
return eval_quasiquote (cadr (r1), add_unquoters (r0));
case cell_symbol_unquote: return eval_env (cadr (r1), r0);
case cell_symbol_quasiquote: return eval_quasiquote (cadr (r1), add_unquoters (r0));
#endif //QUASIQUOTE
#if QUASISYNTAX
if (car (r1) == cell_symbol_unsyntax)
return eval_env (cadr (r1), r0);
if (car (r1) == cell_symbol_quasisyntax)
return eval_quasisyntax (cadr (r1), add_unsyntaxers (r0));
case cell_symbol_unsyntax: return eval_env (cadr (r1), r0);
case cell_symbol_quasisyntax: return eval_quasisyntax (cadr (r1), add_unsyntaxers (r0));
#endif //QUASISYNTAX
default: {
SCM x = expand_macro_env (r1, r0);
if (x != r1)
return eval_env (x, r0);
if (x != r1) return eval_env (x, r0);
SCM m = evlis_env (CDR (r1), r0);
return apply_env (car (r1), m, r0);
}
}
}
case SYMBOL: return assert_defined (r1, assq_ref_cache (r1, r0));
default: return r1;
}
@ -1060,7 +1038,6 @@ gc_init_cells ()
g_cells++;
g_cells[0].type = CHAR;
g_cells[0].value = 'c';
g_free.value = 1; // 0 is tricky
}
SCM