int find_symbol_by_name(Context * ctx, int frame, ContextAddress ip, char * name, Symbol ** sym) {
int found = 0;
*sym = alloc_symbol();
(*sym)->ctx = ctx;
if (frame == STACK_TOP_FRAME && (frame = get_top_frame(ctx)) < 0) return -1;
if (find_pe_symbol_by_name(ctx, frame, ip, name, *sym) >= 0) found = 1;
else if (get_error_code(errno) != ERR_SYM_NOT_FOUND) return -1;
#if ENABLE_RCBP_TEST
if (!found) {
int sym_class = 0;
void * address = NULL;
if (find_test_symbol(ctx, name, &address, &sym_class) >= 0) found = 1;
else if (get_error_code(errno) != ERR_SYM_NOT_FOUND) return -1;
if (found) {
(*sym)->ctx = ctx->mem;
(*sym)->sym_class = sym_class;
(*sym)->address = (ContextAddress)address;
}
}
#endif
if (!found) {
if (find_basic_type_symbol(ctx, name, *sym) >= 0) found = 1;
else if (get_error_code(errno) != ERR_SYM_NOT_FOUND) return -1;
}
if (!found) {
errno = ERR_SYM_NOT_FOUND;
return -1;
}
assert(frame >= 0 || (*sym)->ctx == ctx->mem);
assert((*sym)->ctx == ((*sym)->frame ? ctx : ctx->mem));
assert((*sym)->frame == ((*sym)->ctx == (*sym)->ctx->mem ? 0u : frame - STACK_NO_FRAME));
return 0;
}
int get_symbol_index_type(const Symbol * sym, Symbol ** type) {
DWORD tag = 0;
DWORD index = 0;
Symbol * res = alloc_symbol();
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
res->ctx = sym->ctx;
res->sym_class = SYM_CLASS_TYPE;
res->info = basic_type_info + BST_UNSIGNED;
assert(res->info->size == sizeof(int));
assert(res->info->sign == 0);
assert(res->info->real == 0);
*type = res;
return 0;
}
if (sym->info) {
errno = ERR_INV_CONTEXT;
return -1;
}
*res = *sym;
if (get_type_tag(res, &tag)) return -1;
if (get_type_info(res, TI_GET_ARRAYINDEXTYPEID, &index) < 0) return -1;
res->index = index;
*type = res;
return 0;
}
static BOOL CALLBACK enumerate_symbols_proc(SYMBOL_INFO * info, ULONG symbol_size, VOID * user_context) {
EnumerateSymbolsContext * enum_context = (EnumerateSymbolsContext *)user_context;
Symbol * sym = alloc_symbol();
syminfo2symbol(enum_context->ctx, enum_context->frame, info, sym);
enum_context->call_back(enum_context->args, sym);
return TRUE;
}
int id2symbol(const char * id, Symbol ** res) {
Symbol * sym = NULL;
Context * ctx = NULL;
ULONG64 module = 0;
ULONG index = 0;
unsigned frame = 0;
const Symbol * base = NULL;
const TypeInfo * info = NULL;
size_t length = 0;
const char * p;
if (id != NULL && id[0] == '@' && id[1] == 'P') {
p = id + 2;
length = (size_t)read_hex(&p);
if (*p == '.') p++;
if (id2symbol(p, (Symbol **)&base)) return -1;
ctx = base->ctx;
}
else if (id != NULL && id[0] == '@' && id[1] == 'S') {
unsigned idx = 0;
p = id + 2;
module = (ULONG64)read_hex(&p);
if (*p == '.') p++;
index = (ULONG)read_hex(&p);
if (*p == '.') p++;
frame = (unsigned)read_hex(&p);
if (*p == '.') p++;
idx = (unsigned)read_hex(&p);
if (idx) info = basic_type_info + (idx - 1);
if (*p == '.') p++;
ctx = id2ctx(p);
}
else {
errno = ERR_INV_CONTEXT;
return -1;
}
if (ctx == NULL) {
errno = ERR_INV_CONTEXT;
return -1;
}
sym = alloc_symbol();
sym->ctx = ctx;
sym->module = module;
sym->index = index;
sym->frame = frame;
sym->base = base;
sym->info = info;
sym->length = length;
if (sym->base || sym->info) {
sym->sym_class = SYM_CLASS_TYPE;
}
else {
DWORD dword = 0;
if (get_type_info(sym, TI_GET_SYMTAG, &dword) < 0) return -1;
tag2symclass(sym, dword);
}
*res = sym;
return 0;
}
int get_array_symbol(const Symbol * sym, ContextAddress length, Symbol ** ptr) {
assert(sym->magic == SYMBOL_MAGIC);
*ptr = alloc_symbol();
(*ptr)->ctx = sym->ctx;
(*ptr)->sym_class = SYM_CLASS_TYPE;
(*ptr)->base = (Symbol *)sym;
(*ptr)->length = length;
return 0;
}
int find_symbol_by_addr(Context * ctx, int frame, ContextAddress addr, Symbol ** sym) {
*sym = alloc_symbol();
(*sym)->ctx = ctx;
if (frame == STACK_TOP_FRAME && (frame = get_top_frame(ctx)) < 0) return -1;
if (find_pe_symbol_by_addr(ctx, frame, addr, *sym) < 0) return -1;
assert(frame >= 0 || (*sym)->ctx == ctx->mem);
assert((*sym)->ctx == ((*sym)->frame ? ctx : ctx->mem));
assert((*sym)->frame == ((*sym)->ctx == (*sym)->ctx->mem ? 0u : frame - STACK_NO_FRAME));
return 0;
}
static value make_symbol(cstpair p)
{
struct symbol *sym;
struct string *s = alloc_string_length(p->cst1->u.string.str,
p->cst1->u.string.len);
GCPRO1(s);
s->o.flags |= OBJ_READONLY | OBJ_IMMUTABLE;
sym = alloc_symbol(s, make_constant(p->cst2));
sym->o.flags |= OBJ_READONLY | OBJ_IMMUTABLE;
UNGCPRO();
return sym;
}
obj_t make_symbol(obj_t name)
{
obj_t symbol = find_symbol(name);
if (is_null(symbol)) {
/* Not found. Create one. */
symbol = alloc_symbol(name);
/* with lock */ {
/* verify symbol still absent. */
all_symbols_list = make_pair(symbol, all_symbols_list);
}
}
return symbol;
}
Value* ReadHTTPRequest(std::istream* input, Allocator* alloc) {
stream::http_request req(*input);
std::list<Value*> ereq;
ereq.push_back(alloc_symbol(alloc, str::lcase(req.method())));
ereq.push_back(alloc->allocate<String>(req.url()));
ereq.push_back(LiftContainer(req.headers(), alloc));
ereq.push_back(LiftContainer(req.cookies(), alloc));
ereq.push_back(LiftContainer(req.query_string_values(), alloc));
ereq.push_back(LiftContainer(req.post_values(), alloc));
return LiftContainer(ereq, alloc);
}
static value make_symbol(cstpair p, fncode fn)
{
struct symbol *sym;
struct string *s = alloc_string(p->cst1->u.string);
GCPRO1(s);
SET_IMMUTABLE(s); SET_READONLY(s);
sym = alloc_symbol(s, make_constant(p->cst2, FALSE, fn));
SET_IMMUTABLE(sym); SET_READONLY(sym);
GCPOP(1);
return sym;
}
int get_symbol_type(const Symbol * sym, Symbol ** type) {
DWORD tag = 0;
Symbol * res = alloc_symbol();
assert(sym->magic == SYMBOL_MAGIC);
*res = *sym;
if (!res->base && !res->info) {
if (get_type_tag(res, &tag)) return -1;
}
assert(res->sym_class == SYM_CLASS_TYPE);
*type = res;
return 0;
}
int get_symbol_children(const Symbol * sym, Symbol *** children, int * count) {
static const DWORD FINDCHILDREN_BUF_SIZE = 64;
static TI_FINDCHILDREN_PARAMS * params = NULL;
static Symbol ** buf = NULL;
static unsigned buf_len = 0;
DWORD cnt = 0;
Symbol type = *sym;
DWORD tag = 0;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base || sym->info) {
*children = NULL;
*count = 0;
return 0;
}
if (get_type_tag(&type, &tag)) return -1;
if (get_type_info(&type, TI_GET_CHILDRENCOUNT, &cnt) < 0) return -1;
if (params == NULL) params = (TI_FINDCHILDREN_PARAMS *)loc_alloc(
sizeof(TI_FINDCHILDREN_PARAMS) + (FINDCHILDREN_BUF_SIZE - 1) * sizeof(ULONG));
if (buf_len < cnt) {
buf = (Symbol **)loc_realloc(buf, sizeof(Symbol *) * cnt);
buf_len = cnt;
}
params->Start = 0;
while (params->Start < cnt) {
DWORD i = cnt - (DWORD)params->Start;
params->Count = i > FINDCHILDREN_BUF_SIZE ? FINDCHILDREN_BUF_SIZE : i;
if (get_type_info(&type, TI_FINDCHILDREN, params) < 0) return -1;
for (i = 0; params->Start < cnt; i++) {
DWORD dword = 0;
Symbol * x = alloc_symbol();
*x = *sym;
x->index = params->ChildId[i];
if (get_type_info(x, TI_GET_SYMTAG, &dword) < 0) return -1;
tag2symclass(x, dword);
buf[params->Start++] = x;
}
}
*children = buf;
*count = cnt;
return 0;
}
int get_symbol_base_type(const Symbol * sym, Symbol ** type) {
DWORD tag = 0;
DWORD index = 0;
Symbol * res = NULL;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
*type = (Symbol *)sym->base;
return 0;
}
if (sym->info) {
errno = ERR_INV_CONTEXT;
return -1;
}
res = alloc_symbol();
*res = *sym;
if (get_type_tag(res, &tag)) return -1;
if (get_type_info(res, TI_GET_TYPE, &index) < 0) return -1;
res->index = index;
*type = res;
return 0;
}
obj_t make_anonymous_symbol(void)
{
return alloc_symbol(make_uninitialized());
}
struct environ *setup_builtin() {
struct environ *base_env;
struct symbol *s;
struct callable *ca;
base_env = alloc_environ(NULL);
ca = alloc_builtin_pro(add);
s = alloc_symbol("+");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(mul);
s = alloc_symbol("*");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(length);
s = alloc_symbol("length");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(list);
s = alloc_symbol("list");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_log);
s = alloc_symbol("log");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_sin);
s = alloc_symbol("sin");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_cos);
s = alloc_symbol("cos");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_tan);
s = alloc_symbol("tan");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(cons);
s = alloc_symbol("cons");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_car);
s = alloc_symbol("car");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_cdr);
s = alloc_symbol("cdr");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(min);
s = alloc_symbol("min");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(max);
s = alloc_symbol("max");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(apply);
s = alloc_symbol("apply");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(sub);
s = alloc_symbol("-");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(number_equal);
s = alloc_symbol("=");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(more_than);
s = alloc_symbol(">");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(less_than);
s = alloc_symbol("<");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(more_equal);
s = alloc_symbol(">=");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(less_equal);
s = alloc_symbol("<=");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(null_p);
s = alloc_symbol("null?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(number_p);
s = alloc_symbol("number?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(symbol_p);
s = alloc_symbol("symbol?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(pair_p);
s = alloc_symbol("pair?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(procedure_p);
s = alloc_symbol("procedure?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(bool_p);
s = alloc_symbol("boolean?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(list_p);
s = alloc_symbol("list?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(not);
s = alloc_symbol("not");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(positive_p);
s = alloc_symbol("positive?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(negative_p);
s = alloc_symbol("negative?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(zero_p);
s = alloc_symbol("zero?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(odd_p);
s = alloc_symbol("odd?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(even_p);
s = alloc_symbol("even?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(eq_p);
s = alloc_symbol("eq?");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_read);
s = alloc_symbol("read");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_print);
s = alloc_symbol("print");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_abs);
s = alloc_symbol("abs");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_floor);
s = alloc_symbol("floor");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_ceil);
s = alloc_symbol("ceiling");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(u_sqrt);
s = alloc_symbol("sqrt");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_pro(append);
s = alloc_symbol("append");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(user_eval);
s = alloc_symbol("eval");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(u_if);
s = alloc_symbol("if");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(define);
s = alloc_symbol("define");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(set);
s = alloc_symbol("set!");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(begin);
s = alloc_symbol("begin");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(lambda);
s = alloc_symbol("lambda");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(defmacro);
s = alloc_symbol("defmacro");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(macroexpand);
s = alloc_symbol("macroexpand");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(quote);
s = alloc_symbol("quote");
define_in_env(base_env, s, (struct exp *)ca);
ca = alloc_builtin_syntax(backquote);
s = alloc_symbol("backquote");
define_in_env(base_env, s, (struct exp *)ca);
return base_env;
}
struct symbol *copy_symbol(struct symbol *s)
{
GCCHECK(s);
return alloc_symbol(s->name, s->data);
}
Result Parser_operate(Parser* _self, Symbol previous_operator_symbol)
{
Symbol left_symbol = _self->text[_self->symbol_count];
Symbol operator_symbol = _self->text[_self->symbol_count + 1];
Result ret;
ret.operator_symbol = operator_symbol;
ret.return_value = _self->end_symbol;
///if (operator_symbol == _self->end_symbol)
if (symbol_compare(operator_symbol, _self->end_symbol) == 0)
{
_self->symbol_count++;
ret.return_value = left_symbol;
return ret;
}
ret.return_value = alloc_symbol();
Symbol right_symbol = _self->text[_self->symbol_count + 2];
///if (right_symbol == '(')
if (symbol_compare(right_symbol, s_left_parentheses) == 0)
{
Parser p;
///Parser_Init(&p, _self->text, ')', _self->symbol_count + 3);
Parser_Init(&p, _self->text, s_right_parentheses, _self->symbol_count + 3);
right_symbol = Parser_analyze(&p);
_self->symbol_count = p.symbol_count;
_self->text[_self->symbol_count] = right_symbol;
}
else
_self->symbol_count += 2;
Symbol next_operator_symbol = _self->text[_self->symbol_count + 1];
///if (next_operator_symbol == _self->end_symbol || symbol_compare(operator_symbol, next_operator_symbol) <= 0)
if (symbol_compare(next_operator_symbol, _self->end_symbol) == 0 || symbol_compare(operator_symbol, next_operator_symbol) <= 0)
{
_self->text[_self->symbol_count] = ret.return_value;
#ifdef PARSER_DEBUG
printf("%c = %c %c %c prev %c\n", ret.return_value, left_symbol, operator_symbol, right_symbol, previous_operator_symbol);
#endif
return ret;
}
else
{
Result r = Parser_operate(_self, operator_symbol);
Symbol n = _self->text[_self->symbol_count + 1];
///if (n == _self->end_symbol || symbol_compare(previous_operator_symbol, n) <= 0)
if (symbol_compare(n, _self->end_symbol) == 0 || symbol_compare(previous_operator_symbol, n) <= 0)
{
#ifdef PARSER_DEBUG
printf("%c = %c %c %c prev %c\n", ret.return_value, left_symbol, operator_symbol, r.return_value, previous_operator_symbol);
#endif
return ret;
}
else
{
r = Parser_operate(_self, previous_operator_symbol);
#ifdef PARSER_DEBUG
printf("%c = %c %c %c prev %c\n", ret.return_value, left_symbol, operator_symbol, r.return_value, previous_operator_symbol);
#endif
return ret;
}
}
}
