diff --git a/debug.c b/debug.c index cc388900..8ab62646 100644 --- a/debug.c +++ b/debug.c @@ -1,10 +1,11 @@ -/* debug.c -- optional debugging utilities */ +/* debug.c -- optional debugging utilities */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", - "FCALL6", "FCALL7", "FCALLN", "APPLY1", "JUMP_UNLESS", "JUMP", "RET", "DONE", + {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "FCALL0", "FCALL1", + "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", + "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", diff --git a/eval.c b/eval.c index 3e219c3c..bccd0162 100644 --- a/eval.c +++ b/eval.c @@ -10,6 +10,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler; +static sexp continuation_resumer; #ifdef USE_DEBUG #include "debug.c" @@ -443,9 +444,27 @@ sexp sexp_set_cdr(sexp obj, sexp val) { /*********************** the virtual machine **************************/ +sexp sexp_save_stack(sexp *stack, unsigned int to) { + sexp res, *data; + int i; + res = sexp_make_vector(to, SEXP_UNDEF); + data = sexp_vector_data(res); + for (i=0; idata; - sexp cp, tmp1, tmp2; + sexp cp=SEXP_UNDEF, tmp1, tmp2; int i; loop: @@ -636,8 +655,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fprintf(stderr, "... calling procedure at %p\ncp: ", ip); /* sexp_write(cp, stderr); */ fprintf(stderr, "\n"); - fprintf(stderr, "stack at %d\n", top); - print_stack(stack, top); + /* fprintf(stderr, "stack at %d\n", top); */ + /* print_stack(stack, top); */ break; case OP_APPLY1: tmp1 = stack[top-1]; @@ -656,6 +675,39 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip = bc->data; cp = sexp_procedure_vars(tmp1); break; + case OP_CALLCC: + tmp1 = stack[top-1]; + if (! SEXP_PROCEDUREP(tmp1)) + errx(2, "non-procedure application: %p", tmp1); + stack[top] = sexp_make_integer(1); + stack[top+1] = sexp_make_integer(ip); + stack[top+2] = cp; + tmp2 = sexp_save_stack(stack, top+3); +/* fprintf(stderr, "saved: ", top); */ +/* sexp_write(tmp2, cur_error_port); */ +/* fprintf(stderr, "\n", top); */ + stack[top-1] = sexp_make_procedure(continuation_resumer, + sexp_vector(1, tmp2)); + top+=3; + bc = sexp_procedure_code(tmp1); + ip = bc->data; + cp = sexp_procedure_vars(tmp1); + break; + case OP_RESUMECC: +/* fprintf(stderr, "resuming continuation (%d)\n", top); */ +/* print_stack(stack, top); */ +/* sexp_write(sexp_vector_ref(cp, 0), cur_error_port); */ +/* fprintf(stderr, "\n"); */ + tmp1 = stack[top-4]; + top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); +/* fprintf(stderr, "... restored stack (%d):\n", top); */ +/* print_stack(stack, top); */ + cp = stack[top-1]; + ip = (unsigned char*) sexp_unbox_integer(stack[top-2]); + i = sexp_unbox_integer(stack[top-3]); + top -= 3; + stack[top-1] = tmp1; + break; case OP_FCALL0: stack[top-1]=((sexp_proc0)stack[top-1])(); break; @@ -718,7 +770,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { return stack[top-1]; } -/************************** eval interface ****************************/ +/*********************** standard environment *************************/ static const struct core_form core_forms[] = { {SEXP_CORE, CORE_DEFINE, "define"}, @@ -771,6 +823,7 @@ _OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), _OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), @@ -814,12 +867,19 @@ sexp eval(sexp obj, env e) { } void scheme_init() { + bytecode bc; + unsigned int i=0; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); cur_input_port = sexp_make_input_port(stdin); cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); + bc->tag = SEXP_BYTECODE; + bc->len = 16; + emit(&bc, &i, OP_RESUMECC); + continuation_resumer = (sexp) bc; } } diff --git a/eval.h b/eval.h index b3677280..849e4564 100644 --- a/eval.h +++ b/eval.h @@ -29,9 +29,6 @@ typedef struct bytecode { unsigned char data[]; } *bytecode; -/* env binding: #(id chain offset flags) */ -/* chain is the index into the closure parent list (0 for current lambda) */ -/* macros/constants have a value instead of chain */ typedef struct env { char tag; struct env *parent; @@ -85,6 +82,9 @@ enum opcode_classes { enum opcode_names { OP_NOOP, OP_CALL, + OP_APPLY1, + OP_CALLCC, + OP_RESUMECC, OP_FCALL0, OP_FCALL1, OP_FCALL2, @@ -94,7 +94,6 @@ enum opcode_names { OP_FCALL6, OP_FCALL7, OP_FCALLN, - OP_APPLY1, OP_JUMP_UNLESS, OP_JUMP, OP_RET, diff --git a/sexp.c b/sexp.c index d5275838..497d2cc6 100644 --- a/sexp.c +++ b/sexp.c @@ -275,7 +275,7 @@ sexp sexp_intern(char *str) { return symbol_table[cell]; } -sexp sexp_make_vector(unsigned long len, sexp dflt) { +sexp sexp_make_vector(unsigned int len, sexp dflt) { int i; sexp v = SEXP_NEW(); if (v == NULL) return SEXP_ERROR; @@ -411,10 +411,10 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#()", out); } else { sexp_write_string("#(", out); - sexp_write(out, elts[0]); + sexp_write(elts[0], out); for (i=1; i", out); break; default: - sexp_write_string("#", out); + sexp_printf(out, "#", obj); } } } diff --git a/sexp.h b/sexp.h index e16b1abf..565f1389 100644 --- a/sexp.h +++ b/sexp.h @@ -221,7 +221,7 @@ sexp sexp_make_string(char *str); sexp sexp_make_flonum(double f); int sexp_string_hash(char *str, int acc); sexp sexp_intern(char *str); -sexp sexp_make_vector(unsigned long len, sexp dflt); +sexp sexp_make_vector(unsigned int len, sexp dflt); sexp sexp_list_to_vector(sexp ls); sexp sexp_vector(int count, ...); void sexp_write(sexp obj, sexp out);