/* Deallocation */
cell_t *drop_dependencies(secd_t *secd, cell_t *c) {
enum cell_type t = cell_type(c);
switch (t) {
case CELL_SYM:
if (c->as.sym.size != DONT_FREE_THIS)
free((char *)c->as.sym.data);
/* TODO: this silently ignores symbol memory corruption */
c->as.sym.size = DONT_FREE_THIS;
break;
case CELL_FRAME:
drop_cell(secd, c->as.frame.io);
// fall through
case CELL_CONS:
if (not_nil(c)) {
drop_cell(secd, get_car(c));
drop_cell(secd, get_cdr(c));
}
break;
case CELL_STR:
case CELL_ARRAY:
drop_array(secd, arr_mem(c));
break;
case CELL_REF:
drop_cell(secd, c->as.ref);
break;
case CELL_PORT:
secd_pclose(secd, c);
break;
case CELL_ARRMETA:
if (c->as.mcons.cells) {
size_t size = arrmeta_size(secd, c);
size_t i;
/* free the items */
for (i = 0; i < size; ++i) {
/* don't free uninitialized */
cell_t *ith = meta_mem(c) + i;
if (cell_type(ith) != CELL_UNDEF)
drop_dependencies(secd, ith);
}
}
break;
case CELL_INT: case CELL_FUNC: case CELL_OP:
case CELL_ERROR: case CELL_UNDEF:
return c;
default:
return new_error(secd, "drop_dependencies: unknown cell_type 0x%x", t);
}
return c;
}
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;
}
/*
* Port allocation
*/
static cell_t *init_port_mode(secd_t *secd, cell_t *cell, const char *mode) {
switch (mode[0]) {
case 'r':
cell->as.port.input = true;
if (mode[1] == '+') {
cell->as.port.output = true;
++mode;
} else
cell->as.port.output = false;
if (mode[1] == '\0')
return cell;
break;
case 'w': case 'a':
cell->as.port.output = true;
if (mode[1] == '+') {
cell->as.port.input = true;
++mode;
} else
cell->as.port.input = false;
if (mode[1] == '\0')
return cell;
}
// otherwise fail:
drop_cell(secd, cell);
errorf("new_fileport: failed to parse mode\n");
return new_error(secd, "new_port: failed to parse mode");
}
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 *sexp_lexeme(secd_t *secd, int line, int pos, int prevchar) {
cell_t *result;
secd_parser_t p;
init_parser(secd, &p);
p.line = line;
p.pos = pos;
p.lc = prevchar;
lexnext(&p);
switch (p.token) {
case TOK_EOF:
return new_symbol(secd, EOF_OBJ);
case TOK_SYM:
result = new_lexeme(secd, "sym", new_symbol(secd, p.symtok));
break;
case TOK_NUM:
result = new_lexeme(secd, "int", new_number(secd, p.numtok));
break;
case TOK_STR:
result = new_lexeme(secd, "str", new_string(secd, strmem(p.strtok)));
drop_cell(secd, p.strtok);
break;
case TOK_CHAR:
result = new_lexeme(secd, "char", new_char(secd, p.numtok));
break;
case TOK_QUOTE: case TOK_QQ:
case TOK_UQ: case TOK_UQSPL:
result = new_lexeme(secd, special_form_for(p.token), SECD_NIL);
break;
case TOK_ERR:
result = new_lexeme(secd, "syntax error", SECD_NIL);
break;
default:
result = new_lexeme(secd, "token", new_char(secd, p.token));
}
cell_t *pcharc = new_cons(secd, new_char(secd, p.lc), result);
cell_t *posc = new_cons(secd, new_number(secd, p.pos), pcharc);
cell_t *linec = new_cons(secd, new_number(secd, p.line), posc);
return linec;
}
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;
}
}
static cell_t *read_token(secd_t *secd, secd_parser_t *p) {
int tok;
cell_t *inp = NULL;
switch (tok = p->token) {
case '(':
++p->nested;
inp = read_list(secd, p);
if (p->token != ')')
goto error_exit;
return inp;
case TOK_NUM:
return new_number(secd, p->numtok);
case TOK_CHAR:
return new_char(secd, p->numtok);
case TOK_SYM:
return new_symbol(secd, p->symtok);
case TOK_STR:
inp = new_string(secd, strmem(p->strtok));
drop_cell(secd, p->strtok);
return inp;
case TOK_EOF:
return new_symbol(secd, EOF_OBJ);
case TOK_QUOTE: case TOK_QQ:
case TOK_UQ: case TOK_UQSPL: {
const char *formname = special_form_for(tok);
assert(formname, "No special form for token=%d\n", tok);
inp = sexp_read(secd, p);
assert_cell(inp, "sexp_read: reading subexpression failed");
return new_cons(secd, new_symbol(secd, formname),
new_cons(secd, inp, SECD_NIL));
}
case '#':
switch (tok = lexnext(p)) {
case '(': {
cell_t *tmplist = read_list(secd, p);
if (p->token != ')') {
free_cell(secd, tmplist);
goto error_exit;
}
inp = list_to_vector(secd, tmplist);
free_cell(secd, tmplist);
return inp;
}
case TOK_SYM: {
if (p->symtok[0] == '.') {
int op = secdop_by_name(p->symtok + 1);
if (op < 0)
goto error_exit;
return new_op(secd, op);
}
if (str_eq(p->symtok, "u8")) {
lexnext(p);
inp = read_bytevector(p);
if (p->token != ')')
goto error_exit;
return inp;
}
}
}
errorf("Unknown suffix for #\n");
}
error_exit:
if (inp) free_cell(secd, inp);
errorf("read_token: failed\n");
return new_error(secd, SECD_NIL,
"read_token: failed on token %1$d '%1$c'", p->token);
}
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);
}
