static int
p_shelf_create2(value vinit, type tinit, value vbag, type tbag)
{
pword bag;
pword *pheap, *pglobal;
t_heap_array *obj;
int i, err;
Check_Ref(tbag);
Check_Structure(tinit);
pglobal = vinit.ptr;
i = DidArity(pglobal->val.did);
/* INSTANCE INITIALISATION */
obj = (t_heap_array *) hg_alloc_size(
sizeof(t_heap_array) + i*sizeof(pword));
obj->ref_ctr = 1;
pheap = obj->array;
pheap[0] = pglobal[0];
for (; i > 0; --i)
{
pword *parg = &pglobal[i];
Dereference_(parg);
err = create_heapterm(&pheap[i], parg->val, parg->tag);
Return_If_Not_Success(err);
}
bag = ec_handle(&heap_array_tid, (t_ext_ptr) obj);
Return_Unify_Pw(vbag, tbag, bag.val, bag.tag);
}
static int
_heap_arr_set(t_ext_ptr h,
int i,
pword pw) /* expected to be dereferenced */
{
pword copy_pw;
pword *pheap;
int err, arity;
pheap = ((t_heap_array*)h)->array;
arity = DidArity(pheap[0].val.did);
if (i >= 1 && i <= arity)
{
if ((err = create_heapterm(©_pw, pw.val, pw.tag)) != PSUCCEED)
{ Bip_Error(err); }
a_mutex_lock(&SharedDataLock);
free_heapterm(&pheap[i]);
move_heapterm(©_pw, &pheap[i]);
a_mutex_unlock(&SharedDataLock);
}
else if (i == 0)
{
if (IsStructure(pw.tag) && pw.val.ptr->val.did == pheap[0].val.did)
{
pword *aux = TG;
Push_Struct_Frame(pheap[0].val.did);
for (i=1; i<=arity; ++i)
{
pword *parg = &pw.val.ptr[i];
Dereference_(parg);
if ((err = create_heapterm(aux+i, parg->val, parg->tag)) != PSUCCEED)
{
TG = aux;
Bip_Error(err);
}
}
a_mutex_lock(&SharedDataLock);
for (i=1; i<=arity; ++i)
{
free_heapterm(&pheap[i]);
move_heapterm(aux+i, &pheap[i]);
}
a_mutex_unlock(&SharedDataLock);
TG = aux;
}
else { Bip_Error(RANGE_ERROR); }
}
else
{ Bip_Error(RANGE_ERROR); }
Succeed_;
}
static int
p_text_to_string(value v, type t, value vs, type ts)
{
pword *pw, *list;
char *s;
int len;
pword *old_tg = Gbl_Tg;
if (IsRef(t))
{
Bip_Error(PDELAY_1);
}
if (IsString(t))
{
Kill_DE;
Return_Unify_Pw(v, t, vs, ts);
}
if (IsAtom(t)) /* not including [] ! */
{
Kill_DE;
Return_Unify_String(vs, ts, DidString(v.did));
}
if (IsNil(t))
{
Kill_DE;
Return_Unify_String(vs, ts, empty_string);
}
if (IsList(t)) /* make a string from a list */
{
int element_type = 0;
list = v.ptr; /* space for the string header */
Push_Buffer(1); /* make minimum buffer */
s = (char *) BufferStart(old_tg); /* start of the new string */
for(;;) /* loop through the list */
{
int c;
pw = list++;
Dereference_(pw); /* get the list element */
if (IsRef(pw->tag)) /* check it */
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(pw, pw->tag.all);
Bip_Error(PDELAY);
}
else if (IsInteger(pw->tag)) /* char code */
{
element_type |= 1;
c = pw->val.nint;
if (c < 0 || 255 < c)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
}
else if (IsAtom(pw->tag)) /* char atom */
{
element_type |= 2;
if (DidLength(pw->val.did) != 1)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
c = DidName(pw->val.did)[0];
}
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
*s++ = c;
if (s == (char *) Gbl_Tg) /* we need another pword */
{
Gbl_Tg += 1;
Check_Gc;
}
Dereference_(list); /* get the list tail */
if (IsRef(list->tag))
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(list, list->tag.all);
Bip_Error(PDELAY);
}
else if (IsList(list->tag))
list = list->val.ptr;
else if (IsNil(list->tag))
break; /* end of the list */
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
}
if (element_type != 1 && element_type != 2) /* mixed type list? */
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
*s = '\0'; /* terminate the string */
Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1);
Kill_DE;
Return_Unify_String(vs, ts, old_tg);
}
Bip_Error(TYPE_ERROR);
}
static int
p_string_list(value vs, type ts, value vl, type tl)
{
register pword *pw, *list;
register char *s;
register int len;
pword *old_tg = Gbl_Tg;
if (IsRef(ts)) /* no string given */
{
if (IsRef(tl)) /* we need at least one */
{
Bip_Error(PDELAY_1_2);
}
else if (IsList(tl)) /* make a string from a list */
{
list = vl.ptr; /* space for the string header */
Push_Buffer(1); /* make minimum buffer */
s = (char *) BufferStart(old_tg); /* start of the new string */
for(;;) /* loop through the list */
{
pw = list++;
Dereference_(pw); /* get the list element */
if (IsRef(pw->tag)) /* check it */
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(pw, pw->tag.all);
Bip_Error(PDELAY);
}
else if (!IsInteger(pw->tag))
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
else if (pw->val.nint < 0 || pw->val.nint > 255)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
*s++ = pw->val.nint;
if (s == (char *) Gbl_Tg) /* we need another pword */
{
Gbl_Tg += 1;
Check_Gc;
}
Dereference_(list); /* get the list tail */
if (IsRef(list->tag))
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(list, list->tag.all);
Bip_Error(PDELAY);
}
else if (IsList(list->tag))
list = list->val.ptr;
else if (IsNil(list->tag))
break; /* end of the list */
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
}
*s = '\0'; /* terminate the string */
Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1);
Kill_DE;
Return_Unify_String(vs, ts, old_tg);
}
else if (IsNil(tl))
{
Kill_DE;
Return_Unify_String(vs, ts, empty_string);
}
else
{
Bip_Error(TYPE_ERROR);
}
}
else if (IsString(ts))
{
Kill_DE;
Check_Output_List(tl);
s = StringStart(vs); /* get a pointer to the string */
len = StringLength(vs);
if (len == 0)
{
Return_Unify_Nil(vl, tl);
}
/* Additional a-priori overflow check because adding to TG may
* may wrap around the address space and break Check_Gc below
*/
Check_Available_Pwords(2*len);
pw = Gbl_Tg; /* reserve space for the list */
Gbl_Tg += 2*len;
Check_Gc;
pw->val.nint = *s++ & 0xFFL; /* construct the list */
pw++->tag.kernel = TINT;
while (--len > 0)
{
pw->val.ptr = pw + 1;
pw++->tag.kernel = TLIST;
pw->val.nint = *s++ & 0xFFL;
pw++->tag.kernel = TINT;
}
pw->tag.kernel = TNIL;
Return_Unify_List(vl, tl, old_tg);
}
else
{
Bip_Error(TYPE_ERROR);
}
}
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;
}
