/* machine printing, (write) */
void sexp_pprint(secd_t* secd, cell_t *port, const cell_t *cell) {
switch (cell_type(cell)) {
case CELL_UNDEF: secd_pprintf(secd, port, "#?"); break;
case CELL_INT: secd_pprintf(secd, port, "%d", cell->as.num); break;
case CELL_CHAR:
if (isprint(cell->as.num))
secd_pprintf(secd, port, "#\\%c", (char)cell->as.num);
else
secd_pprintf(secd, port, "#\\x%x", numval(cell));
break;
case CELL_OP: sexp_print_opcode(secd, port, cell->as.op); break;
case CELL_FUNC: secd_pprintf(secd, port, "##func*%p", cell->as.ptr); break;
case CELL_FRAME: secd_pprintf(secd, port,
"##frame@%ld ", cell_index(secd, cell)); break;
case CELL_KONT: secd_pprintf(secd, port,
"##kont@%ld ", cell_index(secd, cell)); break;
case CELL_CONS: sexp_print_list(secd, port, cell); break;
case CELL_ARRAY: sexp_print_array(secd, port, cell); break;
case CELL_STR: secd_pprintf(secd, port, "\"%s\"", strval(cell) + cell->as.str.offset); break;
case CELL_SYM: secd_pprintf(secd, port, "%s", symname(cell)); break;
case CELL_BYTES: sexp_print_bytes(secd, port, strval(cell), mem_size(cell)); break;
case CELL_ERROR: secd_pprintf(secd, port, "#!\"%s\"", errmsg(cell)); break;
case CELL_PORT: sexp_pprint_port(secd, port, cell); break;
case CELL_REF: sexp_pprint(secd, port, cell->as.ref); break;
default: errorf("sexp_print: unknown cell type %d", (int)cell_type(cell));
}
}
void dbg_print_cell(secd_t *secd, const cell_t *c) {
if (is_nil(c)) {
secd_printf(secd, "NIL\n");
return;
}
char buf[128];
if (c->nref > DONT_FREE_THIS - 100000) strncpy(buf, "-", 64);
else snprintf(buf, 128, "%ld", (long)c->nref);
printf("[%ld]^%s: ", cell_index(secd, c), buf);
switch (cell_type(c)) {
case CELL_CONS:
printf("CONS([%ld], [%ld])\n",
cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c)));
break;
case CELL_FRAME:
printf("FRAME(syms: [%ld], vals: [%ld])\n",
cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c)));
break;
case CELL_INT: printf("%d\n", c->as.num); break;
case CELL_CHAR:
if (isprint(c->as.num)) printf("#\\%c\n", (char)c->as.num);
else printf("#x%x\n", c->as.num);
break;
case CELL_OP:
sexp_print_opcode(secd, secd->output_port, c->as.op);
printf("\n");
break;
case CELL_FUNC: printf("*%p()\n", c->as.ptr); break;
case CELL_KONT: printf("KONT[%ld, %ld, %ld]\n",
cell_index(secd, c->as.kont.stack),
cell_index(secd, c->as.kont.env),
cell_index(secd, c->as.kont.ctrl)); break;
case CELL_ARRAY: printf("ARR[%ld]\n",
cell_index(secd, arr_val(c, 0))); break;
case CELL_STR: printf("STR[%ld\n",
cell_index(secd, (cell_t*)strval(c))); break;
case CELL_SYM: printf("SYM[%08x]='%s'\n",
symhash(c), symname(c)); break;
case CELL_BYTES: printf("BVECT[%ld]\n",
cell_index(secd, (cell_t*)strval(c))); break;
case CELL_REF: printf("REF[%ld]\n",
cell_index(secd, c->as.ref)); break;
case CELL_ERROR: printf("ERR[%s]\n", errmsg(c)); break;
case CELL_ARRMETA: printf("META[%ld, %ld]\n",
cell_index(secd, mcons_prev((cell_t*)c)),
cell_index(secd, mcons_next((cell_t*)c))); break;
case CELL_UNDEF: printf("#?\n"); break;
case CELL_FREE: printf("FREE\n"); break;
default: printf("unknown type: %d\n", cell_type(c));
}
}
/* 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;
}
/* human-readable, (display) */
void sexp_display(secd_t *secd, cell_t *port, cell_t *cell) {
switch (cell_type(cell)) {
case CELL_STR:
secd_pprintf(secd, port, "%s", strval(cell));
break;
default: sexp_pprint(secd, port, cell);
}
}
cell_t *secd_type_sym(secd_t *secd, const cell_t *cell) {
const char *type = "unknown";
enum cell_type t = cell_type(cell);
assert(t <= CELL_ERROR, "secd_type_sym: type is invalid");
type = secd_type_names[t];
assert(type, "secd_type_names: unknown type of %d", t);
return new_symbol(secd, type);
}
cell_t *lookup_env(secd_t *secd, const char *symbol, cell_t **symc) {
cell_t *env = secd->env;
assert(cell_type(env) == CELL_CONS,
"lookup_env: environment is not a list");
cell_t *res = lookup_fake_variables(secd, symbol);
if (not_nil(res))
return res;
hash_t symh = secd_strhash(symbol);
while (not_nil(env)) { // walk through frames
cell_t *frame = get_car(env);
if (is_nil(frame)) {
/* skip omega-frame */
env = list_next(secd, env);
continue;
}
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) { // walk through symbols
if (is_symbol(symlist)) {
if (symh == symhash(symlist) && str_eq(symbol, symname(symlist))) {
if (symc != NULL) *symc = symlist;
return vallist;
}
break;
}
cell_t *curc = get_car(symlist);
assert(is_symbol(curc),
"lookup_env: variable at [%ld] is not a symbol\n",
cell_index(secd, curc));
if (symh == symhash(curc) && str_eq(symbol, symname(curc))) {
if (symc != NULL) *symc = curc;
return get_car(vallist);
}
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
//errorf(";; error in lookup_env(): %s not found\n", symbol);
return new_error(secd, SECD_NIL, "Lookup failed for: '%s'", symbol);
}
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 sexp_print_list(secd_t *secd, cell_t *port, const cell_t *cell) {
secd_pprintf(secd, port, "(");
const cell_t *iter = cell;
while (not_nil(iter)) {
if (iter != cell) secd_pprintf(secd, port, " ");
if (cell_type(iter) != CELL_CONS) {
secd_pprintf(secd, port, ". ");
sexp_pprint(secd, port, iter); break;
}
cell_t *head = get_car(iter);
sexp_pprint(secd, port, head);
iter = list_next(secd, iter);
}
secd_pprintf(secd, port, ") ");
}
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 * 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 *serialize_cell(secd_t *secd, cell_t *cell) {
cell_t *opt = SECD_NIL;
switch (cell_type(cell)) {
case CELL_CONS: {
cell_t *cdrc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), cdrc);
}
break;
case CELL_PORT:
opt = secd_pserialize(secd, cell);
break;
case CELL_SYM:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_INT:
case CELL_CHAR:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_OP: {
cell_t *namec = new_symbol(secd, opcode_table[ cell->as.op ].name);
opt = new_cons(secd, namec, SECD_NIL);
}
break;
case CELL_FUNC:
opt = new_cons(secd, new_number(secd, (long)cell->as.ptr), SECD_NIL);
break;
case CELL_ARRMETA: {
cell_t *typec = chain_sym(secd,
(cell->as.mcons.cells ? "cell" : "byte"),
SECD_NIL);
cell_t *nextc = chain_index(secd, mcons_next(cell), typec);
opt = chain_index(secd, mcons_prev(cell), nextc);
}
break;
case CELL_FRAME: {
cell_t *ioc = chain_index(secd, cell->as.frame.io, SECD_NIL);
cell_t *nextc = chain_index(secd, cell->as.frame.cons.cdr, ioc);
opt = chain_index(secd, cell->as.frame.cons.car, nextc);
}
break;
case CELL_KONT: {
cell_t *kctrl = chain_index(secd, cell->as.kont.ctrl, SECD_NIL);
cell_t *kenv = chain_index(secd, cell->as.kont.env, kctrl);
opt = chain_index(secd, cell->as.kont.stack, kenv);
}
break;
case CELL_FREE: {
cell_t *nextc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), nextc);
}
break;
case CELL_REF:
opt = chain_index(secd, cell->as.ref, SECD_NIL);
break;
case CELL_ERROR:
opt = chain_string(secd, errmsg(cell), SECD_NIL);
break;
case CELL_UNDEF:
opt = SECD_NIL;
break;
case CELL_ARRAY:
opt = chain_index(secd, arr_val(cell, -1), SECD_NIL);
break;
case CELL_STR:
case CELL_BYTES:
opt = chain_index(secd, arr_meta((cell_t *)strmem(cell)), SECD_NIL);
break;
}
opt = new_cons(secd, secd_type_sym(secd, cell), opt);
cell_t *refc = new_cons(secd, new_number(secd, cell->nref), opt);
return new_cons(secd, new_number(secd, cell - secd->begin), refc);
}
int
cell_cmp(lex_ctxt* lexic, tree_cell* c1, tree_cell* c2)
{
int flag, x1, x2, typ, typ1, typ2;
char *s1, *s2;
int len_s1, len_s2, len_min;
#if NASL_DEBUG >= 0
if (c1 == NULL || c1 == FAKE_CELL)
nasl_perror(lexic, "cell_cmp: c1 == NULL !\n");
if (c2 == NULL || c2 == FAKE_CELL)
nasl_perror(lexic, "cell_cmp: c2 == NULL !\n");
#endif
/* We first convert the cell to atomic types */
c1 = cell2atom(lexic, c1);
c2 = cell2atom(lexic, c2);
/*
* Comparing anything to something else which is entirely different
* may lead to unpredictable results.
* Here are the rules:
* 1. No problem with same types, although we do not compare arrays yet
* 2. No problem with CONST_DATA / CONST_STR
* 3. When an integer is compared to a string, the integer is converted
* 4. When NULL is compared to an integer, it is converted to 0
* 5. When NULL is compared to a string, it is converted to ""
* 6. NULL is "smaller" than anything else (i.e. an array)
* Anything else is an error
*/
typ1 = cell_type(c1);
typ2 = cell_type(c2);
if (typ1 == 0 && typ2 == 0) /* Two NULL */
{
deref_cell(c1); deref_cell(c2);
return 0;
}
if (typ1 == typ2) /* Same type, no problem */
typ = typ1;
else if ((typ1 == CONST_DATA || typ1 == CONST_STR) &&
(typ2 == CONST_DATA || typ2 == CONST_STR))
typ = CONST_DATA; /* Same type in fact (string) */
/* We convert an integer into a string before compare */
else if ((typ1 == CONST_INT && (typ2 == CONST_DATA || typ2 == CONST_STR)) ||
(typ2 == CONST_INT && (typ1 == CONST_DATA || typ1 == CONST_STR)) )
{
#if NASL_DEBUG > 0
nasl_perror(lexic, "cell_cmp: converting integer to string\n");
#endif
typ = CONST_DATA;
}
else if (typ1 == 0) /* 1st argument is null */
if (typ2 == CONST_INT || typ2 == CONST_DATA || typ2 == CONST_STR)
typ = typ2; /* We convert it to 0 or "" */
else
{
deref_cell(c1); deref_cell(c2);
return -1; /* NULL is smaller than anything else */
}
else if (typ2 == 0) /* 2nd argument is null */
if (typ1 == CONST_INT || typ1 == CONST_DATA || typ1 == CONST_STR)
typ = typ1; /* We convert it to 0 or "" */
else
{
deref_cell(c1); deref_cell(c2);
return 1; /* Anything else is greater than NULL */
}
else
{
nasl_perror(lexic, "cell_cmp: comparing %s and %s does not make sense\n", nasl_type_name(typ1), nasl_type_name(typ2));
deref_cell(c1); deref_cell(c2);
return 0;
}
switch (typ)
{
case CONST_INT:
x1 = cell2int(lexic, c1);
x2 = cell2int(lexic, c2);
deref_cell(c1); deref_cell(c2);
return x1 - x2;
case CONST_STR:
case CONST_DATA:
s1 = cell2str(lexic, c1);
if (typ1 == CONST_STR || typ1 == CONST_DATA)
len_s1 = c1->size;
else if (s1 == NULL)
len_s1 = 0;
else
len_s1 = strlen(s1);
s2 = cell2str(lexic, c2);
if (typ2 == CONST_STR || typ2 == CONST_DATA)
len_s2 = c2->size;
else if (s2 == NULL)
len_s2 = 0;
else
len_s2 = strlen(s2);
len_min = len_s1 < len_s2 ? len_s1 : len_s2;
flag = 0;
if (len_min > 0)
flag = memcmp(s1, s2, len_min);
if (flag == 0)
flag = len_s1 - len_s2;
efree(&s1); efree(&s2);
deref_cell(c1); deref_cell(c2);
return flag;
case REF_ARRAY:
case DYN_ARRAY:
fprintf(stderr, "cell_cmp: cannot compare arrays yet\n");
deref_cell(c1); deref_cell(c2);
return 0;
default:
fprintf(stderr, "cell_cmp: don't known how to compare %s and %s\n",
nasl_type_name(typ1), nasl_type_name(typ2));
deref_cell(c1); deref_cell(c2);
return 0;
}
}