static inline cell_t*
init_cons(secd_t *secd, cell_t *cell, cell_t *car, cell_t *cdr) {
cell->type = CELL_CONS;
cell->as.cons.car = share_cell(secd, car);
cell->as.cons.cdr = share_cell(secd, cdr);
return cell;
}
/* use *args_io to override *stdin* | *stdout* if not NIL */
static cell_t *new_frame_io(secd_t *secd, cell_t *args_io, cell_t *prevenv) {
cell_t *prev_io = get_car(prevenv)->as.frame.io;
if (is_nil(args_io))
return prev_io; /* share previous i/o */
if (is_nil(get_car(args_io)))
args_io->as.cons.car = share_cell(secd, get_car(prev_io));
if (is_nil(get_cdr(args_io)))
args_io->as.cons.cdr = share_cell(secd, get_cdr(prev_io));
return args_io; /* set a new i/o */
}
cell_t *secd_insert_in_frame(secd_t *secd, cell_t *frame, cell_t *sym, cell_t *val) {
cell_t *old_syms = get_car(frame);
cell_t *old_vals = get_cdr(frame);
// an interesting side effect: since there's no check for
// re-binding an existing symbol, we can create multiple
// copies of it on the frame, the last added is found
// during value lookup, but the old ones are persistent
frame->as.cons.car = share_cell(secd, new_cons(secd, sym, old_syms));
frame->as.cons.cdr = share_cell(secd, new_cons(secd, val, old_vals));
drop_cell(secd, old_syms); drop_cell(secd, old_vals);
return frame;
}
static cell_t *read_bytevector(secd_parser_t *p) {
secd_t *secd = p->secd;
assert(p->token == '(', "read_bytevector: '(' expected");
cell_t *tmplist = SECD_NIL;
cell_t *cur;
size_t len = 0;
while (lexnext(p) == TOK_NUM) {
assert((0 <= p->numtok) && (p->numtok < 256),
"read_bytevector: out of range");
cell_t *newc = new_cons(secd, new_number(secd, p->numtok), SECD_NIL);
if (not_nil(tmplist)) {
cur->as.cons.cdr = share_cell(secd, newc);
cur = newc;
} else {
tmplist = cur = newc;
}
++len;
}
cell_t *bvect = new_bytevector_of_size(secd, len);
assert_cell(bvect, "read_bytevector: failed to allocate");
unsigned char *mem = (unsigned char *)strmem(bvect);
cur = tmplist;
size_t i;
for (i = 0; i < len; ++i) {
mem[i] = (unsigned char)numval(list_head(cur));
cur = list_next(secd, cur);
}
free_cell(secd, tmplist);
return bvect;
}
secd_t * init_secd(secd_t *secd, cell_t *heap, size_t ncells) {
secd->free = SECD_NIL;
secd->stack = secd->dump =
secd->control = secd->env = SECD_NIL;
secd->tick = 0;
secd->postop = SECD_NOPOST;
secd_init_mem(secd, heap, ncells);
secd->truth_value = share_cell(secd, new_symbol(secd, SECD_TRUE));
secd->false_value = share_cell(secd, new_symbol(secd, SECD_FALSE));
secd_init_ports(secd);
secd_init_env(secd);
return secd;
}
void secd_init_env(secd_t *secd) {
/* initialize global values */
stdinhash = secd_strhash(SECD_FAKEVAR_STDIN);
stdouthash = secd_strhash(SECD_FAKEVAR_STDOUT);
stddbghash = secd_strhash(SECD_FAKEVAR_STDDBG);
/* initialize the first frame */
cell_t *frame = make_native_frame(secd, native_functions);
cell_t *frame_io = new_cons(secd, secd->input_port, secd->output_port);
frame->as.frame.io = share_cell(secd, frame_io);
/* ready */
cell_t *env = new_cons(secd, frame, SECD_NIL);
secd->env = share_cell(secd, env);
secd->global_env = secd->env;
}
static cell_t *
check_io_args(secd_t *secd, cell_t *sym, cell_t *val, cell_t **args_io) {
/* check for overriden *stdin* or *stdout* */
hash_t symh = symhash(sym);
if ((symh == stdinhash)
&& str_eq(symname(sym), SECD_FAKEVAR_STDIN))
{
assert(cell_type(val) == CELL_PORT, "*stdin* must bind a port");
if (is_nil(*args_io))
*args_io = new_cons(secd, val, SECD_NIL);
else
(*args_io)->as.cons.car = share_cell(secd, val);
} else
if ((symh == stdouthash)
&& str_eq(symname(sym), SECD_FAKEVAR_STDOUT))
{
assert(cell_type(val) == CELL_PORT, "*stdout* must bind a port");
if (is_nil(*args_io))
*args_io = new_cons(secd, SECD_NIL, val);
else
(*args_io)->as.cons.cdr = share_cell(secd, val);
}
return SECD_NIL;
}
static void run_postop(secd_t *secd) {
cell_t *tmp;
switch (secd->postop) {
case SECDPOST_GC:
secd_mark_and_sweep_gc(secd);
break;
case SECDPOST_MACHINE_DUMP:
tmp = new_string(secd, "secdstate.dump");
share_cell(secd, tmp);
secd_dump_state(secd, tmp);
drop_cell(secd, tmp);
break;
case SECD_NOPOST:
break;
}
secd->postop = SECD_NOPOST;
}
cell_t *sexp_parse(secd_t *secd, cell_t *port) {
cell_t *prevport = SECD_NIL;
if (not_nil(port)) {
assert(cell_type(port) == CELL_PORT, "sexp_parse: not a port");
prevport = secd->input_port; // share_cell, drop_cell
secd->input_port = share_cell(secd, port);
}
secd_parser_t p;
init_parser(secd, &p);
cell_t *res = sexp_read(secd, &p);
if (not_nil(prevport)) {
secd->input_port = prevport; //share_cell back
drop_cell(secd, port);
}
return res;
}
cell_t *setup_frame(secd_t *secd, cell_t *argnames, cell_t *argvals, cell_t *env) {
cell_t *args_io = SECD_NIL;
/* setup the new frame */
cell_t *frame = new_frame(secd, argnames, argvals);
cell_t *ret = walk_through_arguments(secd, frame, &args_io);
assert_cell(ret, "setup_frame: argument check failed");
cell_t *new_io = new_frame_io(secd, args_io, env);
assert_cell(new_io, "setup_frame: failed to set new frame I/O\n");
frame->as.frame.io = share_cell(secd, new_io);
secd->input_port = get_car(new_io);
secd->output_port = get_cdr(new_io);
return frame;
}
cell_t * run_secd(secd_t *secd, cell_t *ctrl) {
cell_t *op, *ret;
TIMING_DECLARATIONS(ts_then, ts_now);
share_cell(secd, ctrl);
set_control(secd, &ctrl);
while (true) {
TIMING_START_OPERATION(ts_then);
op = pop_control(secd);
assert_cell(op, "run: no command");
if (cell_type(op) != CELL_OP) {
errorf("run: not an opcode at [%ld]\n", cell_index(secd, op));
dbg_printc(secd, op);
continue;
}
int opind = op->as.op;
if (about_to_halt(secd, opind, &ret))
return ret;
secd_opfunc_t callee = (secd_opfunc_t) opcode_table[ opind ].fun;
ret = callee(secd);
if (is_error(ret))
if (!handle_exception(secd, ret))
return fatal_exception(secd, ret, opind);
drop_cell(secd, op);
TIMING_END_OPERATION(ts_then, ts_now)
run_postop(secd);
++secd->tick;
}
}
cell_t *read_list(secd_t *secd, secd_parser_t *p) {
const char *parse_err = NULL;
cell_t *head = SECD_NIL;
cell_t *tail = SECD_NIL;
cell_t *newtail, *val;
while (true) {
int tok = lexnext(p);
switch (tok) {
case TOK_EOF: case ')':
-- p->nested;
return head;
case '(':
++ p->nested;
val = read_list(secd, p);
if (p->token == TOK_ERR) {
parse_err = "read_list: error reading subexpression";
goto error_exit;
}
if (p->token != ')') {
parse_err = "read_list: TOK_EOF, ')' expected";
goto error_exit;
}
break;
default:
val = read_token(secd, p);
if (is_error(val)) {
parse_err = "read_list: read_token failed";
goto error_exit;
}
/* reading dot-lists */
if (is_symbol(val) && (str_eq(symname(val), "."))) {
free_cell(secd, val);
switch (lexnext(p)) {
case TOK_ERR: case ')':
parse_err = "read_list: failed to read a token after dot";
goto error_exit;
case '(':
/* there may be a list after dot */
val = read_list(secd, p);
if (p->token != ')') {
parse_err = "read_list: expected a ')' reading sublist after dot";
goto error_exit;
}
lexnext(p); // consume ')'
break;
default:
val = read_token(secd, p);
lexnext(p);
}
if (is_nil(head)) /* Guile-like: (. val) returns val */
return val;
tail->as.cons.cdr = share_cell(secd, val);
return head;
}
}
newtail = new_cons(secd, val, SECD_NIL);
if (not_nil(head)) {
tail->as.cons.cdr = share_cell(secd, newtail);
tail = newtail;
} else {
head = tail = newtail;
}
}
error_exit:
free_cell(secd, head);
errorf("read_list: TOK_ERR, %s\n", parse_err);
return new_error(secd, SECD_NIL, parse_err);
}
inline static token_t lexstring(secd_parser_t *p) {
size_t bufsize = 32; /* initial size since string size is not limited */
size_t read_count = 0;
/* to be freed after p->strtok is consumed: */
cell_t *strbuf = new_string_of_size(p->secd, bufsize);
share_cell(p->secd, strbuf);
char *buf = strmem(strbuf);
while (1) {
nextchar(p);
switch (p->lc) {
case '\\':
nextchar(p);
switch (p->lc) {
case 'a' : buf[read_count++] = '\x07'; break;
case 'b' : buf[read_count++] = '\x08'; break;
case 't' : buf[read_count++] = '\x09'; break;
case 'n' : buf[read_count++] = '\x0A'; break;
case 'x': {
char hexbuf[10];
char *hxb = hexbuf;
nextchar(p);
if (!isxdigit(p->lc))
goto cleanup_and_exit;
do {
*hxb++ = p->lc;
nextchar(p);
} while ((hxb - hexbuf < 9) && isxdigit(p->lc));
if (p->lc != ';')
goto cleanup_and_exit;
*hxb = '\0';
unichar_t charcode = (int)strtol(hexbuf, NULL, 16);
char *after = utf8cpy(buf + read_count, charcode);
if (!after)
goto cleanup_and_exit;
read_count = after - buf;
} break;
default:
buf[read_count++] = p->lc;
}
break;
case '"':
nextchar(p);
buf[read_count] = '\0';
p->strtok = strbuf; /* don't forget to free */
return (p->token = TOK_STR);
default:
buf[read_count] = p->lc;
++read_count;
}
if (read_count + 4 >= bufsize) { // +4 because of utf8cpy
/* reallocate */
size_t newbufsize = 2 * bufsize;
cell_t *newstrbuf = new_string_of_size(p->secd, newbufsize);
if (is_error(newstrbuf)) {
secd_errorf(p->secd, "lexstring: not enough memory for a string\n");
goto cleanup_and_exit;
}
//errorf(";# reallocating string to %lu", newbufsize);
char *newbuf = strmem(newstrbuf);
memcpy(newbuf, buf, bufsize);
assign_cell(p->secd, &strbuf, newstrbuf);
buf = newbuf;
bufsize = newbufsize;
}
}
cleanup_and_exit:
drop_cell(p->secd, strbuf);
return (p->token = TOK_ERR);
}
inline static cell_t *share_array(secd_t *secd, cell_t *mem) {
share_cell(secd, arr_meta(mem));
return mem;
}
