int Winapi
ec_handle_events(long int *to_c)
{
int res;
pword * pw;
if (g_emu_.nesting_level > 1)
ec_panic("can't resume nested engine","ec_handle_events()");
if (ec_running())
return PRUNNING;
Make_Nil(&A[1]) /* don't care */
Make_Integer(&A[2], RESUME_SIMPLE);
res = restart_emulc();
if (res != PYIELD)
ec_panic("eclipse emulator did not yield properly","ec_handle_events()");
pw = &A[2];
Dereference_(pw)
if (IsInteger(pw->tag))
*to_c = pw->val.nint;
else
*to_c = 0;
pw = &A[1];
Dereference_(pw)
if (IsInteger(pw->tag))
return pw->val.nint;
else
return TYPE_ERROR;
}
/*
* Must be called on the worker that created the bag, no check yet!
*/
static int
p_dbag_dissolve(value vdbag, type tdbag, value vl, type tl)
{
aport_id_t bag_aport_id;
dbag_descr_t *dbag_descr;
amsg_t this_msg;
amsg_ref_t *this_msg_data_hdr;
pword list;
register pword *car, *cdr;
Check_Integer(tdbag);
bag_aport_id = (aport_id_t) vdbag.nint;
Check_Output_List(tl);
if (aport_get_option(bag_aport_id, APORT_DATA_PTR,
(aport_optval_t *) &dbag_descr) != AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
this_msg = dbag_descr->first.msg;
this_msg_data_hdr = dbag_descr->first.msg_data_hdr;
hp_free_size((generic_ptr) dbag_descr, sizeof(dbag_descr_t));
cdr = &list;
while (this_msg_data_hdr != &dbag_descr->first)
{
pword *pw1;
amsg_t old_msg;
car = TG;
Push_List_Frame();
Make_List(cdr, car);
cdr = car + 1;
pw1 = dbformat_to_term((char*)(this_msg_data_hdr+1), D_UNKNOWN, tdict);
if (!pw1)
{
value va;
va.did = d_.abort;
Bip_Throw(va, tdict);
}
car->val.ptr = pw1->val.ptr;
car->tag.kernel = pw1->tag.kernel;
old_msg = this_msg;
this_msg = this_msg_data_hdr->msg;
this_msg_data_hdr = this_msg_data_hdr->msg_data_hdr;
(void) amsg_free(old_msg);
}
Make_Nil(cdr);
if (aport_deallocate(bag_aport_id) != AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
Return_Unify_Pw(vl, tl, list.val, list.tag);
}
pword *
dbformat_to_term(register char *buf, dident mod, type tmod)
{
register pword *pw;
pword *p;
pword *base, *top;
pword *prev_ld = LD;
pword *r;
pword meta;
word n, t;
int res;
meta.tag.kernel = TNIL;
Load_Int32(n);
base = pw = TG;
TG = WordOffset(TG, n);
if (GlobalStackOverflow)
return (pword *)0;
top = TG;
while (pw < top)
{
Load_Byte(t);
switch (TagTypeC(t))
{
case TINT: /* value */
#ifdef OLD_FORMAT
Load_Int32(n);
#else
Load_Int(n);
#endif
pw->val.nint = n;
pw++->tag.kernel = t;
break;
case TNIL: /* */
pw++->tag.kernel = t;
break;
case TVAR_TAG: /* offset */
Load_Int(n);
pw->val.ptr = WordOffset(base, n);
pw++->tag.kernel = TREF;
break;
case TUNIV: /* offset, length, "string\0" */
case TNAME:
case TMETA:
Load_Int(n);
pw->val.ptr = WordOffset(base, n);
Load_Int(n);
if (n)
{
pw++->tag.kernel = DidTag(t, enter_dict_n(buf, n, 0));
#ifdef OLD_FORMAT
buf += n + 1;
#else
buf += n;
#endif
}
else
pw++->tag.kernel = RefTag(t); /* no name */
if (TagTypeC(t) == TMETA) {
p = TG;
TG += 2;
Check_Gc
p[0].val.ptr = pw;
p[0].tag.kernel = TREF;
p[1] = meta;
meta.val.ptr = p;
meta.tag.kernel = TLIST;
}
break;
case TSUSP:
case TCOMP:
case TLIST:
Load_Int(n);
pw->val.ptr = WordOffset(base, n);
pw++->tag.kernel = t;
break;
case TDICT: /* arity, length, "string\0" */
Load_Int(n);
Load_Int(t);
pw->val.did = enter_dict_n(buf, t, (int) n);
pw++->tag.kernel = TDICT;
#ifdef OLD_FORMAT
buf += t + 1;
#else
buf += t;
#endif
break;
case TDBL: /* length, double */
{
ieee_double d;
Load_Byte(n); /* backward compatibility */
Load_Int32(d.as_struct.mant1);
Load_Int32(d.as_struct.mant0);
Make_Double(pw, d.as_dbl);
pw++;
}
break;
case TIVL: /* double, double */
{
ieee_double dlwb, dupb;
Load_Int32(dlwb.as_struct.mant1);
Load_Int32(dlwb.as_struct.mant0);
Load_Int32(dupb.as_struct.mant1);
Load_Int32(dupb.as_struct.mant0);
Push_Interval(pw->val.ptr, dlwb.as_dbl, dupb.as_dbl);
pw++->tag.kernel = TIVL;
}
break;
case TSTRG: /* length, "string" */
{
register char *string;
Load_Int(n);
Make_Stack_String(n, pw->val, string);
pw++->tag.kernel = TSTRG;
#ifdef OLD_FORMAT
while (n-- >= 0) *string++ = *buf++;
#else
while (n-- > 0) *string++ = *buf++;
*string = 0;
#endif
}
break;
case TDE:
pw[SUSP_LD].val.ptr = LD;
Update_LD(pw)
Load_Int32(n);
pw[SUSP_FLAGS].tag.kernel = n;
pw[SUSP_PRI].val.ptr = (pword *) 0; /* missing */
pw[SUSP_INVOC].tag.kernel = 0;
if (!SuspDead(pw)) {
Load_Byte(n);
Init_Susp_State(pw, n & 0xF, (n>>4) & 0xF);
pw += SUSP_GOAL;
} else {
pw += SUSP_HEADER_SIZE;
}
break;
default:
if (t >= 0 && t <= NTYPES)
{
Load_Int(n);
pw->tag.kernel = t; /* from_string() may change tag! */
if (tag_desc[t].from_string(buf, pw, 10) != PSUCCEED)
{
/* this can happen e.g. if we try to read a bignum
* in an Eclipse that doesn't support them */
Make_Nil(pw);
p_fprintf(current_err_,
"dbformat_to_term: cannot represent constant of type %s\n",
DidName(tag_desc[t].tag_name));
}
++pw;
buf += n+1;
}
else
{
Make_Nil(pw);
p_fprintf(current_err_,
"bad type in dbformat_to_term: 0x%x\n", t);
pw++; buf++;
}
break;
}
int
ec_load_eco_from_stream(stream_id nst, int options, pword *module)
{
int res;
pword *clause, *query, *pw;
pword query_pw, kernel_pw;
pword top_module = *module;
int encoded = 0;
/* we are expecting an eco-encoded file, but we allow text as well */
res = _read_eco_header(nst);
encoded = (res == PSUCCEED);
StreamMode(nst) |= SNOMACROEXP; /* to avoid problems in text-eco files */
kernel_pw.val.did = d_.kernel_sepia;
kernel_pw.tag.kernel = ModuleTag(d_.kernel_sepia);
for(;;)
{
int recreate_module = 0;
pword exports_pw, language_pw;
pword *new_module = 0;
if (encoded) /* encoded dbformat */
{
int n;
word nread;
char *s = ec_getstring(nst, 4, &nread);
if (!(s))
return nread; /* error code */
if (nread < 4)
return (nread == 0) ? PSUCCEED : UNEXPECTED_EOF;
n = (unsigned char) *s++ << 24;
n |= (unsigned char) *s++ << 16;
n |= (unsigned char) *s++ << 8;
n |= (unsigned char) *s;
s = ec_getstring(nst, n, &nread);
if (!(s))
return nread; /* error code */
if (nread < n)
return UNEXPECTED_EOF;
clause = dbformat_to_term(s, module->val.did, module->tag);
if (!clause)
return NOT_DUMP_FILE;
}
else /* text format, call the parser */
{
res = ec_read_term(nst,
(GlobalFlags & VARIABLE_NAMES ? VARNAMES_PLEASE : 0),
&query_pw, 0, 0, module->val, module->tag);
if (res != PSUCCEED)
return (res == PEOF) ? PSUCCEED : NOT_DUMP_FILE;
clause = &query_pw;
}
Dereference_(clause);
if (!IsStructure(clause->tag) || !Query(clause->val.ptr->val.did))
return NOT_DUMP_FILE;
pw = query = clause->val.ptr + 1;
Dereference_(pw);
if (IsStructure(pw->tag)) /* look for special directives */
{
if (pw->val.ptr->val.did == d_.module1)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
Make_Nil(&exports_pw);
Make_Atom(&language_pw, d_eclipse_language_);
}
if (pw->val.ptr->val.did == d_module_interface)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
Make_Nil(&exports_pw);
Make_Atom(&language_pw, d_eclipse_language_);
}
else if (pw->val.ptr->val.did == d_module2)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
exports_pw = pw->val.ptr[2];
Make_Atom(&language_pw, d_eclipse_language_);
}
else if (pw->val.ptr->val.did == d_module3)
{
recreate_module = 1;
new_module = &pw->val.ptr[1];
exports_pw = pw->val.ptr[2];
language_pw = pw->val.ptr[3];
}
else if (pw->val.ptr->val.did == d_begin_module)
{
new_module = &pw->val.ptr[1];
query = &query_pw; /* don't execute anything */
Make_Atom(query, d_.true0);
}
else if (pw->val.ptr->val.did == d_.pragma)
{
query = &query_pw; /* ignore pragmas, replace with true */
Make_Atom(query, d_.true0);
}
}
else if (pw->val.did == d_.system || pw->val.did == d_.system_debug)
{
query = &query_pw; /* ignore pragmas, replace with true */
Make_Atom(query, d_.true0);
}
if (recreate_module) /* build translated module query */
{
pword *pgoal, *pcont;
query = &query_pw;
Make_Struct(query, TG);
/* If module changes, raise CODE_UNIT_LOADED event first */
if (module->val.did != top_module.val.did)
{
pcont = TG;
Push_Struct_Frame(d_.comma);
Make_Struct(&pcont[1], TG);
pgoal = TG;
Push_Struct_Frame(d_.syserror);
Make_Integer(&pgoal[1], CODE_UNIT_LOADED);
Make_Atom(&pgoal[2], d_.eof);
pgoal[3] = *module;
pgoal[4] = *module;
Make_Struct(&pcont[2], TG);
}
pcont = TG;
Push_Struct_Frame(d_.comma);
Make_Struct(&pcont[1], TG);
pgoal = TG;
Push_Struct_Frame(d_erase_module_);
pgoal[1] = *new_module;
Make_Struct(&pcont[2], TG);
pgoal = TG;
Push_Struct_Frame(d_create_module3_);
pgoal[1] = *new_module;
pgoal[2] = exports_pw;
pgoal[3] = language_pw;
res = query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag);
}
else
{
/* execute the query/directive */
res = query_emulc(query->val, query->tag, module->val, module->tag);
}
if (res != PSUCCEED)
{
pw = TG;
Push_Struct_Frame(d_.syserror);
Make_Integer(&pw[1], QUERY_FAILED);
pw[2] = *query;
pw[3] = *module;
pw[4] = *module;
query = &query_pw;
Make_Struct(query, pw);
(void) query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag);
}
if (new_module) /* change to new context module */
{
Dereference_(new_module);
*module = *new_module;
}
}
return PSUCCEED;
}
