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

core: Rewrite eval_apply in continuation passing style.

Browse source 
* mes.c (scm_vm_evlis, scm_vm_evlis2, scm_vm_evlis3, scm_vm_apply,
  scm_vm_apply2, scm_vm_eval, scm_vm_eval_set_x, scm_vm_eval_macro,
  scm_vm_eval2, scm_vm_macro_expand, scm_vm_begin,
  scm_vm_begin_read_input_file, scm_vm_begin2, scm_vm_if,
  scm_vm_if_expr, scm_vm_call_with_values, scm_vm_call_with_values2,
  scm_vm_return): New specials.
  (scm_vm_eval_car, scm_vm_eval_cdr, scm_vm_eval_cons,
  scm_vm_eval_null_p)[PRIMITIVE-EVAL]: New specials.
  (eval_apply_t, g_target): Remove.
  (push_cc): New function.
  (eval_apply): Rewrite.
  (vm_call, eval_env, apply_env, eval_env, macro_expand_env, begin_env,
  call_with_values_env): Remove.
* posix.c (stderr_): Update.
* reader.c (read_input_file_env): Update.
* module/mes/base-0.mes: Update.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-28 21:55:42 +01:00
parent b83d583755
commit b66cd8627c
10 changed files with 247 additions and 141 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib.c
View file

@ -144,7 +144,7 @@ dump ()
SCM
load_env (SCM a) ///((internal))
{
r0 =a;
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 (!g_function) r0 = mes_builtins (r0);

340
mes.c
View file

@ -122,6 +122,34 @@ scm scm_symbol_null_p = {SYMBOL, "null?"};
scm scm_symbol_eq_p = {SYMBOL, "eq?"};
scm scm_symbol_cons = {SYMBOL, "cons"};
scm scm_vm_evlis = {SPECIAL, "*vm-evlis*"};
scm scm_vm_evlis2 = {SPECIAL, "*vm-evlis2*"};
scm scm_vm_evlis3 = {SPECIAL, "*vm-evlis3*"};
scm scm_vm_apply = {SPECIAL, "core:apply"};
scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
scm scm_vm_eval = {SPECIAL, "core:eval"};
#if 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*"};
scm scm_vm_eval_null_p = {SPECIAL, "*vm-eval-null-p*"};
#endif
scm scm_vm_eval_set_x = {SPECIAL, "*vm-eval-set!*"};
scm scm_vm_eval_macro = {SPECIAL, "*vm-eval-macro*"};
scm scm_vm_eval2 = {SPECIAL, "*vm-eval2*"};
scm scm_vm_macro_expand = {SPECIAL, "core:macro-expand"};
scm scm_vm_begin = {SPECIAL, "*vm-begin*"};
scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"};
scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
scm scm_vm_if = {SPECIAL, "*vm-if*"};
scm scm_vm_if_expr = {SPECIAL, "*vm-if-expr*"};
scm scm_vm_call_with_values2 = {SPECIAL, "*vm-call-with-values2*"};
scm scm_vm_return = {SPECIAL, "*vm-return*"};
scm scm_test = {SYMBOL, "test"};
int g_free = 0;
scm *g_cells;
scm *g_news = 0;
@ -169,6 +197,7 @@ SCM r3 = 0; // continuation
#define CAAR(x) CAR (CAR (x))
#define CADAR(x) CAR (CDR (CAR (x)))
#define CADDR(x) CAR (CDR (CDR (x)))
#define CDDDR(x) CDR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#define CADR(x) CAR (CDR (x))
@ -331,9 +360,6 @@ assq_ref_cache (SCM x, SCM a)
return cdr (x);
}
enum eval_apply_t {EVLIS, APPLY, EVAL, MACRO_EXPAND, BEGIN, IF, CALL_WITH_VALUES};
enum eval_apply_t g_target;
SCM
call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
{
@ -343,33 +369,77 @@ call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
return cell_unspecified;
}
SCM
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
{
SCM x = r3;
r3 = c;
r2 = p2;
gc_push_frame ();
r1 = p1;
r0 = a;
r3 = x;
return cell_unspecified;
}
SCM
eval_apply ()
{
switch (g_target)
eval_apply:
if (g_free + GC_SAFETY > ARENA_SIZE)
gc_pop_frame (gc (gc_push_frame ()));
switch (r3)
{
case EVLIS: goto evlis;
case APPLY: goto apply;
case EVAL: goto eval;
case MACRO_EXPAND: goto macro_expand;
case BEGIN: goto begin;
case IF: goto label_if;
case CALL_WITH_VALUES: goto call_with_values;
case cell_vm_evlis: goto evlis;
case cell_vm_evlis2: goto evlis2;
case cell_vm_evlis3: goto evlis3;
case cell_vm_apply: goto apply;
case cell_vm_apply2: goto apply2;
case cell_vm_eval: goto eval;
#if FIXED_PRIMITIVES
case cell_vm_eval_car: goto eval_car;
case cell_vm_eval_cdr: goto eval_cdr;
case cell_vm_eval_cons: goto eval_cons;
case cell_vm_eval_null_p: goto eval_null_p;
#endif
case cell_vm_eval_set_x: goto eval_set_x;
case cell_vm_eval_macro: goto eval_macro;
case cell_vm_eval2: goto eval2;
case cell_vm_macro_expand: goto macro_expand;
case cell_vm_begin: goto begin;
case cell_vm_begin_read_input_file: goto begin_read_input_file;
case cell_vm_begin2: goto begin2;
case cell_vm_if: goto vm_if;
case cell_vm_if_expr: goto if_expr;
case cell_vm_call_with_values2: goto call_with_values2;
case cell_vm_return: goto vm_return;
case cell_unspecified: return r1;
default:
assert (0);
}
SCM x = cell_nil;
SCM y = cell_nil;
evlis:
if (r1 == cell_nil) return cell_nil;
if (r1 == cell_nil) goto vm_return;
if (TYPE (r1) != PAIR) goto eval;
r2 = eval_env (car (r1), r0);
r1 = evlis_env (cdr (r1), r0);
return cons (r2, r1);
push_cc (car (r1), r1, r0, cell_vm_evlis2);
goto eval;
evlis2:
push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
goto evlis;
evlis3:
r1 = cons (r2, r1);
goto vm_return;
apply:
switch (TYPE (car (r1)))
{
case FUNCTION: {
check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
return call (car (r1), cdr (r1));
r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
goto vm_return;
}
case CLOSURE:
{
@ -383,6 +453,23 @@ eval_apply ()
call_lambda (body, p, aa, r0);
goto begin;
}
case SPECIAL:
{
switch (car (r1))
{
case cell_vm_apply:
{
push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
goto apply;
}
case cell_vm_eval:
{
push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
goto eval;
}
default: error ("cannot apply special: ", car (r1));
}
}
case SYMBOL:
{
if (car (r1) == cell_symbol_call_with_values)
@ -390,7 +477,11 @@ eval_apply ()
r1 = cdr (r1);
goto call_with_values;
}
if (car (r1) == cell_symbol_current_module) return r0;
if (car (r1) == cell_symbol_current_module)
{
r1 = r0;
goto vm_return;
}
break;
}
case PAIR:
@ -409,9 +500,11 @@ eval_apply ()
}
}
}
SCM e = eval_env (car (r1), r0);
check_apply (e, car (r1));
r1 = cons (e, cdr (r1));
push_cc (car (r1), r1, r0, cell_vm_apply2);
goto eval;
apply2:
check_apply (r1, car (r2));
r1 = cons (r1, cdr (r2));
goto apply;
eval:
@ -422,40 +515,86 @@ eval_apply ()
switch (car (r1))
{
#if FIXED_PRIMITIVES
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));
case cell_symbol_car:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
eval_car:
x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
}
case cell_symbol_cdr:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
eval_cdr:
x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
}
case cell_symbol_cons: {
push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
eval_cons:
x = r1;
gc_pop_frame ();
r1 = cons (CAR (x), CADR (x));
goto eval_apply;
}
case cell_symbol_null_p:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
goto eval;
eval_null_p:
x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
}
#endif // FIXED_PRIMITIVES
case cell_symbol_quote: return cadr (r1);
case cell_symbol_quote:
{
x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply;
}
case cell_symbol_begin: goto begin;
case cell_symbol_lambda:
return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
case cell_symbol_if: {r1=cdr (r1); goto label_if;}
case cell_symbol_set_x: {
SCM x = eval_env (car (cddr (r1)), r0); return set_env_x (cadr (r1), x, r0);
}
{
r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
goto vm_return;
}
case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
case cell_symbol_set_x:
{
push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x);
goto eval;
eval_set_x:
x = r2;
r1 = set_env_x (cadr (x), r1, r0);
goto vm_return;
}
case cell_vm_macro_expand:
{
push_cc (cadr (r1), r1, r0, cell_vm_return);
goto macro_expand;
}
default: {
SCM x = macro_expand_env (r1, r0);
if (x != r1)
push_cc (r1, r1, r0, cell_vm_eval_macro);
goto macro_expand;
eval_macro:
x = r2;
if (r1 != r2)
{
if (TYPE (x) == PAIR)
if (TYPE (r1) == PAIR)
{
set_cdr_x (r1, cdr (x));
set_car_x (r1, car (x));
set_cdr_x (r2, cdr (r1));
set_car_x (r2, car (r1));
}
r1 = x;
goto eval;
}
SCM m = evlis_env (CDR (r1), r0);
r1 = cons (car (r1), m);
push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis;
eval2:
r1 = cons (car (r2), r1);
goto apply;
}
}
}
case SYMBOL: return assert_defined (r1, assq_ref_cache (r1, r0));
default: return r1;
case SYMBOL:
{
r1 = assert_defined (r1, assq_ref_cache (r1, r0));
goto vm_return;
}
default: goto vm_return;
}
SCM macro;
@ -479,11 +618,10 @@ eval_apply ()
goto apply;
}
}
return r1;
goto vm_return;
SCM r;
begin:
r = cell_unspecified;
x = cell_unspecified;
while (r1 != cell_nil) {
if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR)
{
@ -491,8 +629,10 @@ eval_apply ()
r1 = append2 (cdar (r1), cdr (r1));
else if (caar (r1) == cell_symbol_primitive_load)
{
SCM f = read_input_file_env (r0);
r1 = append2 (f, cdr (r1));
push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
goto apply;
begin_read_input_file:
r1 = append2 (r1, cdr (r2));
}
}
if (CDR (r1) == cell_nil)
@ -500,14 +640,21 @@ eval_apply ()
r1 = car (r1);
goto eval;
}
r = eval_env (car (r1), r0);
r1 = CDR (r1);
push_cc (CAR (r1), r1, r0, cell_vm_begin2);
goto eval;
begin2:
x = r1;
r1 = CDR (r2);
}
return r;
r1 = x;
goto vm_return;
SCM x;
label_if:
x = eval_env (car (r1), r0);
vm_if:
push_cc (car (r1), r1, r0, cell_vm_if_expr);
goto eval;
if_expr:
x = r1;
r1 = r2;
if (x != cell_f)
{
r1 = cadr (r1);
@ -518,15 +665,23 @@ eval_apply ()
r1 = car (cddr (r1));
goto eval;
}
return cell_unspecified;
r1 = cell_unspecified;
goto vm_return;
SCM v;
call_with_values:
v = apply_env (car (r1), cell_nil, r0);
if (TYPE (v) == VALUES)
v = CDR (v);
r1 = cons (cadr (r1), v);
push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
goto apply;
call_with_values2:
if (TYPE (r1) == VALUES)
r1 = CDR (r1);
r1 = cons (cadr (r2), r1);
goto apply;
vm_return:
x = r1;
gc_pop_frame ();
r1 = x;
goto eval_apply;
}
SCM
@ -577,66 +732,11 @@ gc_push_frame ()
}
SCM
vm_call (function0_t f, SCM p1, SCM a)
apply (SCM f, SCM x, SCM a) ///((internal))
{
gc_push_frame ();
r1 = p1;
r0 = a;
if (g_free + GC_SAFETY > ARENA_SIZE)
gc_pop_frame (gc (gc_push_frame ()));
SCM r = f ();
gc_pop_frame ();
return r;
}
SCM
evlis_env (SCM m, SCM a)
{
g_target = EVLIS;
return vm_call (eval_apply, m, a);
}
SCM
apply_env (SCM fn, SCM x, SCM a)
{
g_target = APPLY;
return vm_call (eval_apply, cons (fn, x), a);
}
SCM
eval_env (SCM e, SCM a)
{
g_target = EVAL;
return vm_call (eval_apply, e, a);
}
SCM
macro_expand_env (SCM e, SCM a)
{
g_target = MACRO_EXPAND;
return vm_call (eval_apply, e, a);
}
SCM
begin_env (SCM e, SCM a)
{
g_target = BEGIN;
return vm_call (eval_apply, e, a);
}
SCM
if_env (SCM e, SCM a)
{
g_target = IF;
return vm_call (eval_apply, e, a);
}
SCM
call_with_values_env (SCM producer, SCM consumer, SCM a)
{
g_target = CALL_WITH_VALUES;
return vm_call (eval_apply, cons (producer, cons (consumer, cell_nil)), a);
push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_apply;
return eval_apply ();
}
SCM
@ -1023,6 +1123,7 @@ main (int argc, char *argv[])
if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);return 0;};
g_stdin = stdin;
r0 = mes_environment ();
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
@ -1031,7 +1132,10 @@ main (int argc, char *argv[])
for (int i=argc; i; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i-1])), lst);
r0 = acons (cell_symbol_argv, lst, r0);
stderr_ (begin_env (program, r0));
push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin;
r1 = eval_apply ();
stderr_ (r1);
fputs ("", stderr);
gc (g_stack);
#if __GNUC__

15
module/mes/base-0.mes
View file

@ -32,9 +32,8 @@
(define guile-1.8? #f)
(define guile-2? #f)
(define (primitive-eval e) (eval-env e (current-module)))
(define eval eval-env)
(define (macro-expand e) (macro-expand-env e (current-module)))
(define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval)
(define quotient /)
@ -54,11 +53,11 @@
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (apply-env cons* (cdr rest) (current-module)))))
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t) (apply-env f (cons h t) (current-module)))
(define (apply f h . t)
(if (null? t) (apply-env f h (current-module))
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define-macro (cond . clauses)
@ -141,9 +140,9 @@
(define (mes-load-module-env module a)
(push! *input-ports* (current-input-port))
(set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module))))
(let ((x (eval-env (append (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(let ((x (core:eval (append (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(set-current-input-port (pop! *input-ports*))
x))
(define (not x)

2
module/mes/fluids.mes
View file

@ -84,7 +84,7 @@
;; (define (expand bindings a)
;; (if (null? bindings)
;; (cons (car bindings) (expand (cdr bindings) a))))
;; (eval-env (begin ,@bodies) (expand ',bindings (current-module)))))
;; (eval (begin ,@bodies) (expand ',bindings (current-module)))))
(define (dynamic-wind in-guard thunk out-guard)
(in-guard)

6
module/mes/psyntax-0.mes
View file

@ -21,8 +21,8 @@
(define (interaction-environment) (current-module))
(define (eval x . environment)
(eval-env (if (and (pair? x) (equal? (car x) "noexpand")) (cadr x) x)
(if (null? environment) (current-module) (car environment))))
(core:eval (if (and (pair? x) (equal? (car x) "noexpand")) (cadr x) x)
(if (null? environment) (current-module) (car environment))))
(define annotation? (lambda (x) #f))
(define (self-evaluating? x)
@ -30,7 +30,7 @@
(define (void) (if #f #f))
(define macro-expand #f)
(define sc-expand #f)
(define sc-chi #f)
(define sc-expand3 #f)

1
module/mes/psyntax-1.mes
View file

@ -28,3 +28,4 @@
(define datum->syntax datum->syntax-object)
(define syntax->datum syntax-object->datum)
(set! macro-expand sc-expand)

14
module/mes/read-0.mes
View file

@ -60,8 +60,8 @@
(set! sexp:define
(lambda (e a)
(if (atom? (cadr e)) (cons (cadr e) (eval-env (car (cddr e)) a))
(cons (car (cadr e)) (eval-env (cons (quote lambda) (cons (cdr (cadr e)) (cddr e))) a)))))
(if (atom? (cadr e)) (cons (cadr e) (core:eval (car (cddr e)) a))
(cons (car (cadr e)) (core:eval (cons (quote lambda) (cons (cdr (cadr e)) (cddr e))) a)))))
(set! env:macro
(lambda (name+entry)
@ -73,7 +73,7 @@
(set! cons*
(lambda (. rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (apply-env cons* (cdr rest) (current-module))))))
(cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
(env:define
(env:macro
@ -124,7 +124,7 @@
(define (symbol->keyword s)
(make-cell <cell:keyword> (symbol->list s) 0))
(define (read)
(read-word (read-byte) (list) (current-module)))
@ -299,7 +299,9 @@
((or (and (> c 96) (< c 123))
(eq? c 45)
(eq? c 63)
(and (> c 47) (< c 58))) (read-word (read-byte) (append2 w (cons c (list))) a))
(and (> c 47) (< c 58)))
(read-word (read-byte) (append2 w (cons c (list))) a))
((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
((eq? c 40) (if (null? w) (read-list a)
(begin (unread-byte c) (lookup w a))))
((eq? c 41) (if (null? w) (quote *FOOBAR*)
@ -328,5 +330,5 @@
(#t (read-word (read-byte) (append2 w (cons c (list))) a))))
((lambda (p)
(begin-env p (current-module)))
(core:eval (cons (quote begin) p) (current-module)))
(read-input-file)))

4
module/mes/repl.mes
View file

@ -120,7 +120,7 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(display sexp)
(display "]")
(newline))
(display (macro-expand sexp))
(display (core:macro-expand sexp))
(newline)))
(define (scexpand)
@ -170,7 +170,7 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(loop a))))
((and (pair? sexp) (eq? (car sexp) 'mes-use-module))
(loop (mes-load-module-env (cadr sexp) a)))
(else (let ((e (eval-env sexp a)))
(else (let ((e (eval sexp a)))
(if (eq? e *unspecified*) (loop a)
(let ((id (string->symbol (string-append "$" (number->string count)))))
(set! count (+ count 1))

2
posix.c
View file

@ -86,7 +86,7 @@ stderr_ (SCM x)
if (TYPE (x) == STRING)
fprintf (stderr, string_to_cstring (x));
else if ((write = assq_ref_cache (cell_symbol_write, r0)) != cell_undefined)
apply_env (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
apply (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
fprintf (stderr, string_to_cstring (x));
else if (TYPE (x) == NUMBER)

2
reader.c
View file

@ -31,7 +31,7 @@ read_input_file_env (SCM a)
{
r0 = a;
if (assq_ref_cache (cell_symbol_read_input_file, r0) != cell_undefined)
return apply_env (cell_symbol_read_input_file, cell_nil, r0);
return apply (cell_symbol_read_input_file, cell_nil, r0);
return read_input_file_env_ (read_env (r0), r0);
}