mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
initial call/cc support
This commit is contained in:
Alex Shinn
parent
df8bd4bc04
commit
dea136014b
5 changed files with 77 additions and 17 deletions
9
debug.c
9
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",
|
||||
|
|
|
|||
68
eval.c
68
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; i<to; i++)
|
||||
data[i] = stack[i];
|
||||
return res;
|
||||
}
|
||||
|
||||
unsigned int sexp_restore_stack(sexp saved, sexp *current) {
|
||||
int len = sexp_vector_length(saved), i;
|
||||
sexp *from = sexp_vector_data(saved);
|
||||
for (i=0; i<len; i++)
|
||||
current[i] = from[i];
|
||||
return len;
|
||||
}
|
||||
|
||||
sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
||||
unsigned char *ip=bc->data;
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
7
eval.h
7
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,
|
||||
|
|
|
|||
8
sexp.c
8
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<len; i++) {
|
||||
sexp_write_char(' ', out);
|
||||
sexp_write(out, elts[i]);
|
||||
sexp_write(elts[i], out);
|
||||
}
|
||||
sexp_write_char(')', out);
|
||||
}
|
||||
|
|
@ -483,7 +483,7 @@ void sexp_write (sexp obj, sexp out) {
|
|||
case (sexp_uint_t) SEXP_UNDEF:
|
||||
sexp_write_string("#<undef>", out); break;
|
||||
default:
|
||||
sexp_write_string("#<error>", out);
|
||||
sexp_printf(out, "#<invalid: %p>", obj);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
2
sexp.h
2
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);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue