Esempio n. 1
0
/* 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));
    }
}
Esempio n. 2
0
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));
    }
}
Esempio n. 3
0
File: memory.c Progetto: 8l/SECD
/* 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;
}
Esempio n. 4
0
/* 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);
    }
}
Esempio n. 5
0
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);
}
Esempio n. 6
0
File: env.c Progetto: EarlGray/SECD
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);
}
Esempio n. 7
0
File: env.c Progetto: EarlGray/SECD
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;
}
Esempio n. 8
0
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, ") ");
}
Esempio n. 9
0
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;
}
Esempio n. 10
0
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;
    }
}
Esempio n. 11
0
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);
}
Esempio n. 12
0
File: exec.c Progetto: OPSF/uClinux
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;
    }
}