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;
}
lisp_object* LF_atom(lisp_object* obj)
{
if(get_type_tag(get_car(obj)) == TYPE_CONS){
return create_boolean(0);
}
return create_boolean(1);
}
lisp_object* eval(lisp_object* obj, lisp_object* env)
{
data_type type = get_type_tag(obj);
lisp_object *opecode, *ret;
switch(type){
case TYPE_BOOLEAN:
case TYPE_NUMBER:
case TYPE_CHAR:
case TYPE_SUBR:
case TYPE_FSUBR:
case TYPE_EXPR:
case TYPE_FEXPR:
case TYPE_STRING:
case TYPE_PORT:
case TYPE_NULL:
case TYPE_VECTOR:
return obj;
case TYPE_SYMBOL:
ret = assoc(obj, env);
if(null(ret)){
fprintf(stderr, "eval:undefined variable\n");
return create_empty_list();// たぶん、toplevelに戻ったほうがいい
}
return ret;
case TYPE_CONS:
opecode = eval(get_car(obj), env);
type = get_type_tag(opecode);
switch(type){
case TYPE_SUBR:
case TYPE_EXPR:
return apply(opecode, evls(get_cdr(obj), env));
case TYPE_FSUBR:
case TYPE_FEXPR:
return apply(opecode, get_cdr(obj));
default:
fprintf(stderr, "eval:not function\n");
return create_empty_list();
}
default:
fprintf(stderr, "eval:undefined type\n");
return create_empty_list();
}
}
lisp_object* apply(lisp_object* opecode, lisp_object* operand)
{
data_type type = get_type_tag(opecode);
switch(type){
case TYPE_SUBR:
return ((opecode->obj).subr)(operand);
case TYPE_EXPR:
//stab
default:
return create_empty_list();
}
}
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_length(const Symbol * sym, ContextAddress * length) {
DWORD res = 0;
Symbol type = *sym;
DWORD tag = 0;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
*length = sym->length == 0 ? 1 : sym->length;
return 0;
}
if (sym->info) {
errno = ERR_INV_CONTEXT;
return -1;
}
if (get_type_tag(&type, &tag)) return -1;
if (get_type_info(&type, TI_GET_COUNT, &res) < 0) return -1;
*length = res;
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;
}
int get_symbol_lower_bound(const Symbol * sym, int64_t * value) {
Symbol type = *sym;
DWORD tag = 0;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
*value = 0;
return 0;
}
if (sym->info) {
errno = ERR_INV_CONTEXT;
return -1;
}
if (get_type_tag(&type, &tag)) return -1;
switch (tag) {
case SymTagArrayType:
/* TODO: Windows array symbol lower bound value */
*value = 0;
return 0;
}
errno = ERR_INV_CONTEXT;
return -1;
}
int get_symbol_size(const Symbol * sym, ContextAddress * size) {
uint64_t res = 0;
DWORD tag = 0;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
if (sym->length > 0) {
if (get_symbol_size(sym->base, size)) return -1;
*size *= sym->length;
}
else {
*size = sizeof(void *);
}
return 0;
}
if (sym->info) {
*size = sym->info->size;
return 0;
}
if (sym->module == 0) {
errno = set_errno(ERR_OTHER, "Debug info not available");
return -1;
}
if (sym->sym_class == SYM_CLASS_REFERENCE || sym->sym_class == SYM_CLASS_FUNCTION) {
SYMBOL_INFO * info = NULL;
if (get_sym_info(sym, sym->index, &info) < 0) return -1;
res = info->Size;
}
else {
Symbol type = *sym;
if (get_type_tag(&type, &tag)) return -1;
if (get_type_info(&type, TI_GET_LENGTH, &res) < 0) return -1;
}
*size = (ContextAddress)res;
return 0;
}
bool Type::is_string() const { return get_type_tag() == STRING_TYPE_TAG; }
bool Type::is_int() const { return get_type_tag() == INT_TYPE_TAG; }
bool Type::is_record() const { return get_type_tag() == RECORD_TYPE_TAG; }
bool Type::is_array() const { return get_type_tag() == ARRAY_TYPE_TAG; }
bool Type::is_valid() const { return get_type_tag() != INVALID_TYPE_TAG; }
std::string Type::get_type_name() const {
return std::string( type_tag_to_string(get_type_tag()) ); }
int get_symbol_type_class(const Symbol * sym, int * type_class) {
int res = TYPE_CLASS_UNKNOWN;
Symbol type = *sym;
DWORD tag = 0;
DWORD base = 0;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
*type_class = sym->length == 0 ? TYPE_CLASS_POINTER : TYPE_CLASS_ARRAY;
return 0;
}
if (sym->info) {
if (sym->info->real) {
*type_class = TYPE_CLASS_REAL;
}
else if (sym->info->sign) {
*type_class = TYPE_CLASS_INTEGER;
}
else {
*type_class = TYPE_CLASS_CARDINAL;
}
return 0;
}
if (get_type_tag(&type, &tag)) return -1;
switch (tag) {
case SymTagFunction:
case SymTagPublicSymbol:
res = TYPE_CLASS_FUNCTION;
break;
case SymTagEnum:
res = TYPE_CLASS_ENUMERATION;
break;
case SymTagFunctionType:
res = TYPE_CLASS_FUNCTION;
break;
case SymTagPointerType:
res = TYPE_CLASS_POINTER;
break;
case SymTagArrayType:
res = TYPE_CLASS_ARRAY;
break;
case SymTagUDT:
res = TYPE_CLASS_COMPOSITE;
break;
case SymTagBaseType:
if (get_type_info(&type, TI_GET_BASETYPE, &base) < 0) return -1;
switch (base) {
case btNoType:
break;
case btVoid:
case btChar:
case btWChar:
case btInt:
case btBool:
case btLong:
case btBit:
res = TYPE_CLASS_INTEGER;
break;
case btUInt:
case btULong:
res = TYPE_CLASS_CARDINAL;
break;
case btFloat:
res = TYPE_CLASS_REAL;
break;
case btBCD:
case btCurrency:
case btDate:
case btVariant:
case btComplex:
case btBSTR:
case btHresult:
break;
}
break;
}
*type_class = res;
return 0;
}
int get_symbol_name(const Symbol * sym, char ** name) {
WCHAR * ptr = NULL;
assert(sym->magic == SYMBOL_MAGIC);
if (sym->base) {
*name = NULL;
return 0;
}
if (sym->info) {
*name = sym->info->name;
return 0;
}
*name = NULL;
if (get_type_info(sym, TI_GET_SYMNAME, &ptr) < 0) ptr = NULL;
if (ptr != NULL && wcscmp(ptr, L"<unnamed-tag>") == 0) ptr = NULL;
if (ptr != NULL) {
int len = 0;
int err = 0;
if (tmp_buf == NULL) {
tmp_buf_size = 256;
tmp_buf = (char *)loc_alloc(tmp_buf_size);
}
for (;;) {
len = WideCharToMultiByte(CP_UTF8, 0, ptr, -1, tmp_buf, tmp_buf_size - 1, NULL, NULL);
if (len != 0) break;
err = GetLastError();
if (err != ERROR_INSUFFICIENT_BUFFER) {
set_win32_errno(err);
return -1;
}
tmp_buf_size *= 2;
tmp_buf = (char *)loc_realloc(tmp_buf, tmp_buf_size);
}
HeapFree(GetProcessHeap(), 0, ptr);
tmp_buf[len] = 0;
*name = tmp_buf;
}
else {
DWORD tag = 0;
Symbol type = *sym;
if (get_type_tag(&type, &tag)) return -1;
if (tag == SymTagBaseType) {
ContextAddress size = 0;
int type_class = 0;
unsigned char sign = 0;
unsigned char real = 0;
const TypeInfo * p = basic_type_info;
if (get_symbol_size(&type, &size)) return -1;
if (get_symbol_type_class(&type, &type_class)) return -1;
if (type_class == TYPE_CLASS_INTEGER) sign = 1;
else if (type_class == TYPE_CLASS_REAL) real = sign = 1;
while (p->name != NULL) {
if (p->size == size && p->sign == sign && p->real == real) {
*name = p->name;
break;
}
p++;
}
}
}
return 0;
}
bool Type::is_bool() const { return get_type_tag() == BOOL_TYPE_TAG; }
