int
p_print_array(value va, type ta,
value vm, type tm)
{
int size = 1; /* number of array elements */
pword *p;
uword *dim;
dident wdid;
int arity;
Error_If_Ref(ta);
if (IsAtom(ta)) /* a global variable */
wdid = va.did;
else /* an array */
{
Get_Functor_Did(va, ta, wdid);
Get_Visible_Array_Header(wdid, vm, tm, p);
if (!IsStructure(p->tag)) /* error if not prolog */
{
Error(TYPE_ERROR);
}
dim = (uword *) p->val.ptr;
dim++; /* skip the did */
for (arity = DidArity(wdid); arity; arity--)
size *= *dim++; /* compute the size */
}
Get_Visible_Array_Address(wdid, vm, tm, p);
for (; size; size--, p++)
{
Write(p->val, p->tag, Current_Output);
Fprintf(Current_Output, " ");
}
Succeed;
}
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_tool_body(value vi, type ti, value vb, type tb, value vmb, type tmb, value vm, type tm)
{
dident di;
pri *procb, *proci;
int flags, arity;
dident module;
dident pdid;
pword *ptr = Gbl_Tg;
vmcode *code;
int err;
Prepare_Requests;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
if (!IsRef(tb)
&& (!IsStructure(tb)
|| vb.ptr->val.did != d_.quotient))
{
Bip_Error(TYPE_ERROR);
}
Check_Output_Atom_Or_Nil(vmb, tmb);
if (!(proci = visible_procedure(di, vm.did, tm, PRI_CREATE)))
{
Get_Bip_Error(err);
Bip_Error(err);
}
if (!_tool_body(proci, &pdid, &arity, &module))
{
Get_Bip_Error(err);
Bip_Error(err);
}
Gbl_Tg += 3;
Check_Gc;
ptr[0].tag.kernel = TDICT;
ptr[0].val.did = d_.quotient;
ptr[1].tag.kernel = TDICT;
ptr[1].val.did = add_dict(pdid, 0);
ptr[2].tag.kernel = TINT;
ptr[2].val.nint = arity;
Request_Unify_Atom(vmb, tmb, module);
Request_Unify_Structure(vb, tb, ptr);
Return_Unify;
}
void
Bindable::ValidateWithEventsVarsInHandlesListsAndSynthesizePropertiesIfRequired()
{
BCSYM_Container *ContainerOfHandlingMethods = CurrentContainer();
if (!IsClass(ContainerOfHandlingMethods) &&
!IsStructure(ContainerOfHandlingMethods) &&
!IsStdModule(ContainerOfHandlingMethods))
{
return;
}
Symbols
SymbolFactory(
CurrentCompilerInstance(),
CurrentAllocator(),
NULL,
CurrentGenericBindingCache());
BCITER_CHILD Members(ContainerOfHandlingMethods);
while(BCSYM_NamedRoot *Member = Members.GetNext())
{
// only method implementations can have handles clauses
if (!Member->IsMethodImpl())
{
continue;
}
BCSYM_Proc *Proc = Member->PProc();
BCITER_Handles iterHandles(Member->PMethodImpl());
BCSYM_HandlesList *Handles = iterHandles.GetNext();
if (!Handles)
{
continue;
}
ErrorTable *ErrorLog = CurrentErrorLog(Proc);
for(;
Handles;
Handles = iterHandles.GetNext())
{
if (Handles->IsMyBase() ||
Handles->IsEventFromMeOrMyClass())
{
continue;
}
bool FoundInBase;
BCSYM_Variable *WithEventsVar =
GetWithEventsVarReferredToInHandlesClause(
Handles,
FoundInBase);
if (!WithEventsVar)
{
// "Handles clause requires a WithEvents variable."
ReportErrorAtLocation(
ERRID_NoWithEventsVarOnHandlesList,
ErrorLog,
Handles->GetLocationOfWithEventsVar());
Handles->SetIsBad();
}
else if (WithEventsVar->IsBad() ||
WithEventsVar->IsBadVariableType() || // the type of the variable is good, but is not a class or interface
WithEventsVar->GetType()->IsBad()) // the type of the variable is bad
{
// Any metadata errors on a symbol should be reported at the location
// the symbol is used in source code
//
if (DefinedInMetaData(WithEventsVar->GetContainer()))
{
VSASSERT( !DefinedInMetaData(CurrentContainer()),
"How can Current Context for handles clauses not be in VB Source Code ?!");
WithEventsVar->ReportError(
CurrentCompilerInstance(),
ErrorLog,
Handles->GetLocationOfWithEventsVar());
}
Handles->SetIsBad();
}
else
{
// get the withevents property if possible
BCSYM_Property *WithEventsProperty =
GetWithEventsPropertyForWithEventsVariable(WithEventsVar->PVariable());
// Create it if it doesn't exist (for handling events defined on
// WithEvent vars that exist on a base class).
//
if (!WithEventsProperty)
{
VSASSERT(FoundInBase,
"Why do we have to synthesize a property for a withevents variable in the current class ? It should already have been synthesized in declared!!");
WithEventsProperty =
SynthesizeWithEventsProperty(WithEventsVar->PVariable(), SymbolFactory);
WithEventsProperty->SetCreatedByHandlesClause(Handles);
}
Handles->SetWithEventsProperty(WithEventsProperty);
}
}
}
}
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;
}
