static pword
_heap_arr_get(t_ext_ptr h, int i) /* assumed to return dereferenced result */
{
pword result;
pword *pheap;
int arity;
pheap = ((t_heap_array*)h)->array;
arity = DidArity(pheap[0].val.did);
a_mutex_lock(&SharedDataLock);
if (i > 0 && i <= arity)
{
get_heapterm(&pheap[i], &result);
}
else /* get the whole array-term */
{
Make_Struct(&result,TG);
Push_Struct_Frame(pheap[0].val.did);
for (i=1; i<=arity; ++i)
{
get_heapterm(&pheap[i], &result.val.ptr[i]);
}
}
a_mutex_unlock(&SharedDataLock);
return result;
}
static int
_report_error(int err,
dident arg1, /* any arity */
dident module, /* arity 0 */
type mod_tag)
{
int res;
pword *old_tg = TG;
pword *tg = TG;
pword mod, goal;
Make_Struct(&goal, TG);
Push_Struct_Frame(d_.syserror); ++tg;
Make_Integer(tg, -err); ++tg;
Make_Struct(tg, TG); ++tg;
tg->val.did = module;
tg++->tag.all = mod_tag.all;
tg->val.did = module;
tg++->tag.all = mod_tag.all;
Push_Struct_Frame(d_.quotient); ++tg;
Make_Atom(tg, add_dict(arg1,0)); ++tg;
Make_Integer(tg, DidArity(arg1));
mod.val.did = d_.kernel_sepia;
mod.tag.kernel = ModuleTag(d_.kernel_sepia);
res = query_emulc(goal.val, goal.tag, mod.val, mod.tag);
TG = old_tg;
return res;
}
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
p_shelf_create3(value vkey, type tkey, value vinit, type tinit, value vbag, type tbag)
{
dident key_did;
pword *p, bag;
t_heap_array *obj;
int i;
Check_Ref(tbag);
Get_Functor_Did(vkey, tkey, key_did);
i = DidArity(key_did);
if (i < 1)
{ Bip_Error(RANGE_ERROR); }
/* INSTANCE INITIALISATION */
obj = (t_heap_array *) hg_alloc_size(
sizeof(t_heap_array) + i*sizeof(pword));
obj->ref_ctr = 1;
p = obj->array;
for (; i > 0; --i)
{
int err = create_heapterm(&p[i], vinit, tinit);
Return_If_Not_Success(err);
}
p[0].val.did = key_did;
p[0].tag.kernel = TDICT;
bag = ec_handle(&heap_array_tid, (t_ext_ptr) obj);
Return_Unify_Pw(vbag, tbag, bag.val, bag.tag);
}
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;
}
void
print_procedure(dident wdid, vmcode *code)
{
extern int als(word addr);
p_fprintf(current_output_, "\n%s/", DidName(wdid));
p_fprintf(current_output_, "%d:\n", DidArity(wdid));
(void) als((word) code);
ec_flush(current_output_);
}
static void
_mark_heap_array(t_heap_array *obj) /* obj != NULL */
{
pword *p = obj->array;
int i = DidArity(p[0].val.did);
mark_dids_from_pwords(p, p + 1);
for (; i > 0; --i)
{
mark_dids_from_heapterm(&p[i]);
}
}
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
_compatible_def_use(pri *def, pri *use)
{
uint32 conflicts;
char *reason = NULL;
/* if not yet referenced, any change is allowed */
if (!PriReferenced(use))
return 1;
/* don't allow changing certain flags */
conflicts = (def->flags ^ use->flags) &
(use->flags & CODE_DEFINED ?
PF_DONT_CHANGE_WHEN_DEFINED :
PF_DONT_CHANGE_WHEN_REFERENCED);
if (conflicts)
{
if (conflicts & TOOL)
reason = "tool declaration";
else if (conflicts & PROC_DYNAMIC)
reason = "static/dynamic";
else if (conflicts & PROC_DEMON)
reason = "demon declaration";
else if (conflicts & PROC_PARALLEL)
reason = "parallel declaration";
else if (conflicts & (CODETYPE|ARGPASSING|UNIFTYPE))
reason = "calling convention";
else
reason = "predicate properties";
}
/* other restrictions when already referenced */
if (def->mode != use->mode)
reason = "mode declaration";
if (def->trans_function != use->trans_function)
reason = "inline declaration";
if (reason)
{
p_fprintf(warning_output_,
"Definition of %s/%d in module %s is incompatible (%s) with call in module %s\n",
DidName(def->did), DidArity(def->did), DidName(def->module_def),
reason, DidName(use->module_def));
ec_flush(warning_output_);
return 0;
}
return 1;
}
static int
p_shelf_dec(value vhandle, type thandle, value vi, type ti, value vmod, type tmod)
{
t_heap_array *obj;
pword *pw;
Get_Shelf(vhandle, thandle, vmod, tmod, obj);
Check_Integer(ti);
if (vi.nint < 1 || vi.nint > DidArity(obj->array[0].val.did))
{ Bip_Error(RANGE_ERROR); }
pw = &obj->array[vi.nint];
Check_Integer(pw->tag);
if (pw->val.nint <= 0)
{
Fail_;
}
--pw->val.nint;
Succeed_;
}
static int
p_shelf_get(value vhandle, type thandle, value vi, type ti, value vval, type tval, value vmod, type tmod)
{
t_heap_array *obj;
pword pw;
pw.val = vval;
pw.tag = tval;
Get_Shelf(vhandle, thandle, vmod, tmod, obj);
Check_Integer(ti);
if (vi.nint < 0 || vi.nint > DidArity(obj->array[0].val.did))
{ Bip_Error(RANGE_ERROR); }
pw = _heap_arr_get(obj, vi.nint);
if (IsRef(pw.tag))
{
Succeed_; /* nothing to unify */
}
Return_Unify_Pw(vval, tval, pw.val, pw.tag);
}
static void
_free_heap_array(t_heap_array *obj) /* obj != NULL */
{
if (--obj->ref_ctr <= 0)
{
pword *p = obj->array;
int arity = DidArity(p[0].val.did);
int i;
for (i = arity; i > 0; --i)
{
free_heapterm(&p[i]);
}
hg_free_size(obj, sizeof(t_heap_array) + arity*sizeof(pword));
#ifdef DEBUG_RECORD
p_fprintf(current_err_, "\n_free_heap_array(0x%x)", obj);
ec_flush(current_err_);
#endif
}
}
static int
_tool_body(pri *proci, dident *pdid, int *parity, dident *pmodule)
{
pri *procb;
int flags;
vmcode *code;
flags = proci->flags;
code = proci->code.vmc;
if (!(flags & CODE_DEFINED))
{
if (flags & AUTOLOAD)
{ Set_Bip_Error(NOT_LOADED); }
else
{ Set_Bip_Error(NOENTRY); }
return 0;
}
if (!(flags & TOOL))
{
Set_Bip_Error(NO_TOOL);
return 0;
}
if (PriCodeType(proci) == VMCODE)
{
if (DebugProc(proci))
procb = (pri *) *(code + DEBUG_LENGTH + 1);
else
procb = (pri *) *(code + 1);
*pdid = procb->did;
*parity = DidArity(procb->did);
*pmodule = procb->module_def;
}
else /* don't know how to get the tool body */
{
Set_Bip_Error(NO_TOOL);
return 0;
}
return 1;
}
/*
* visible_op(functor, module) return a pointer to the visible operator
* under functor (an infix operator if functor is arity 2, an unary operator
* if functor is of arity 1 (if a prefix and a postfix are visible,
* the prefix is returned).
* return 0 if no operator is visible from module under functor.
* NOTE : when there is a prefix/postfix conflict, a local declaration
* should be return when there is one (e.g. local postfix and global prefix).
*/
opi*
visible_op(dident functor, dident module, type mod_tag, int *res)
{
opi *operator_prop;
int arity;
dident atom = add_dict(functor, 0);
if ((arity = DidArity(functor)) == 1)
{
/* look for a unary operator: first try FX,FY then XF,YF */
operator_prop = visible_prefix_op(atom, module, mod_tag, res);
/* visible_prefix_op() also finds FXX and FXY: ignore them here */
if (!operator_prop || IsPrefix2(operator_prop))
{
/* no unary prefix, look for postfix */
operator_prop = visible_postfix_op(atom, module, mod_tag, res);
}
}
else if (arity == 2)
{
/* look for a binary operator, first try XFX,XFY,YFX then FXX,FXY */
operator_prop = visible_infix_op(atom, module, mod_tag, res);
if (!operator_prop)
{
/* no infix, look for binary prefix */
operator_prop = visible_prefix_op(atom, module, mod_tag, res);
if (operator_prop && !IsPrefix2(operator_prop))
operator_prop = (opi *) 0;
}
}
else /* arity != 1 && arity != 2 so it is not an operator */
{
*res = PERROR; /* means no operator */
return 0;
}
return operator_prop;
}
int
p_transform(value val1, type tag1,
value val2, type tag2)
{
pword *p = Gbl_Tg;
dident did1; /* the DID of the structure */
int arity; /* its arity */
int i;
/* the first argument must be a structure */
Check_Structure(tag1);
/* the second argument must be a structure or a variable */
Check_Output_Structure(tag2);
/* val1 points to the functor */
did1 = val1.ptr->val.did;
arity = DidArity(did1);
/* reserve space for the functor and (arity + 1) args */
Gbl_Tg += arity + 2;
/* insert the functor - the same name and higher arity */
p[0].tag.kernel = TDICT;
p[0].val.did = Did(DidName(did1), arity + 1);
/* copy the arguments */
for (i = 1; i <= arity; i++)
{
p[i].tag.all = val1.ptr[i].tag.all;
p[i].val.all = val1.ptr[i].val.all;
/* on some machines use p[i] = val1.ptr[i] */
}
/* now create the free variable in the last argument;
* it is a self-reference
*/
p[arity + 1].tag.kernel = TREF;
p[arity + 1].val.ptr = p + (arity + 1);
/* and unify with the second argument */
Return_Unify_Structure(val2, tag2, p);
}
vmcode *
print_am(register vmcode *code,
vmcode **label,
int *res,
int option) /* ALS|PROCLAB */
{
dident did1;
int inst;
if (*label == code)
*label = NULL; /* the label is about to being printed */
if (InvalidAddress(code))
inst = Inst_Error;
else
inst = Get_Int_Opcode(code++);
if (inst < 0 || inst > NUMBER_OP)
{
p_fprintf(current_output_, "Undefined opcode in print_am: %d",
inst);
code = 0;
*res = PFAIL;
}
if (inst == Code_end) {
*res = PSUCCEED;
return 0;
}
else if (inst == Comment)
return (vmcode *) code + (*code + 1);
else
{
#ifdef PRINTAM
if (option & PROCLAB) /* try to print the location */
{
extern pri *ec_code_procedure(vmcode *code);
pri *pd = ec_code_procedure(code-1);
if (pd)
p_fprintf(current_output_,"%s/%d+%d:\n",
DidName(PriDid(pd)), DidArity(PriDid(pd)),
code - PriCode(pd) - 1);
}
#endif
p_fprintf(current_output_, "\t%s\t", inst_name[inst]);
switch (inst)
{
case Failure:
case Nop:
case Clause:
break;
case Read_void:
case Read_variable:
case Read_reference:
case Read_nil:
case Read_test_var:
case Write_variable:
case Write_void:
case Write_nil:
case Write_list:
case Write_first_list:
case Match_meta:
case Match_last_meta:
case First:
case Push_void:
case Push_variable:
case Push_nil:
case Push_list:
case Puts_variable:
case Puts_list:
case Puts_nil:
case Occur_check_next:
case Dfid_test:
#if (NREGTMP > 0)
case FirstTR:
#endif /* NREGTMP */
case Inst_Error:
case Continue_after_exception:
case Refail:
break;
case Write_named_void:
case Write_named_variable:
case Push_self_reference:
case Write_meta:
NamedVar;
break;
case CutAM:
case MoveAM:
case Get_nilAM:
case Out_get_nilAM:
case In_get_nilAM:
case Read_variableAM:
case Read_referenceAM:
case Read_valueAM:
case Read_matched_valueAM:
case Write_valueAM:
case Write_local_valueAM:
case Put_nilAM:
case Out_get_listAM:
case Get_list_argumentsAM:
case Get_structure_argumentsAM:
case Write_variableAM:
case Put_variableAM:
case Put_global_variableAM:
case Put_listAM:
case Push_variableAM:
case Push_valueAM:
case Push_local_valueAM:
case Puts_valueAM:
case SavecutAM:
case BI_Exit:
case BI_SetBipError:
case BI_GetBipError:
case BI_Free:
case BI_Var:
case BI_NonVar:
case BI_Atom:
case BI_Integer:
case BI_Float:
case BI_Breal:
case BI_Real:
case BI_Rational:
case BI_String:
case BI_Number:
case BI_Atomic:
case BI_Compound:
case BI_Meta:
case BI_IsSuspension:
case BI_IsHandle:
case BI_IsEvent:
case BI_IsList:
case BI_Bignum:
case BI_Callable:
Am;
break;
case Write_named_variableAM:
case Put_named_variableAM:
Am;
NamedVar;
break;
case Put_named_variableAML:
Am;
Perm;
NamedVar;
break;
case Put_referenceAM:
Am;
case Puts_reference:
VarOffset;
NamedVar;
break;
case Put_referenceAML:
Am;
case Puts_referenceL:
Perm;
VarOffset;
NamedVar;
break;
case Move3AMAM:
Am;
/* fall through */
case ShiftAMAMAMAMAM:
Am;
/* fall through */
case ShiftAMAMAMAM:
case Move2AMAM:
Am;
/* fall through */
case ShiftAMAMAM:
case RotAMAMAM:
case BI_NotIdentList:
Am;
/* fall through */
case BI_Identical:
case BI_NotIdentical:
case BI_Inequality:
case SwapAMAM:
case Read_variable2AM:
case Write_variable2AM:
case Write_local_value2AM:
case Push_local_value2AM:
case Put_variable2AM:
Am;
Am;
break;
case BI_MakeSuspension:
Am;
/* fall through */
case BI_Add:
case BI_Sub:
case BI_Mul:
case BI_Quot:
case BI_Div:
case BI_Rem:
case BI_FloorDiv:
case BI_FloorRem:
case BI_And:
case BI_Or:
case BI_Xor:
case BI_Lt:
case BI_Le:
case BI_Gt:
case BI_Ge:
case BI_Eq:
case BI_Ne:
case BI_Arg:
Am;
/* fall through */
case BI_Minus:
case BI_Bitnot:
case BI_CutToStamp:
case BI_Arity:
Am;
Am;
ArgDesc;
break;
case BI_Addi:
Am;
Integer;
Am;
ArgDesc;
break;
#define NREGARG 0
#if (NREGARG > 0)
case MoveAR:
case Get_nilAR:
case Out_get_nilAR:
case In_get_nilAR:
case Read_variableAR:
case Read_valueAR:
case Read_matched_valueAR:
case Write_valueAR:
case Write_local_valueAR:
case Put_nilAR:
case Out_get_listAR:
case Get_list_argumentsAR:
case Get_structure_argumentsAR:
case Write_variableAR:
case Put_variableAR:
case Put_listAR:
case Push_variableAR:
case Push_valueAR:
case Push_local_valueAR:
case Puts_variableAR:
case Puts_valueAR:
case Test_varAR:
case Test_groundAR:
case Push_referenceAR:
Ar;
break;
case Write_named_variableAR:
case Put_named_variableAR:
Ar;
NamedVar;
break;
#endif /* NREGARG */
case Read_variableL:
case Read_referenceL:
case Write_variableL:
case Read_valueL:
case Read_matched_valueL:
case Write_valueL:
case Write_local_valueL:
case Push_init_variableL:
case Push_variableL:
case Push_valueL:
case Push_local_valueL:
case Puts_variableL:
case Puts_valueL:
case Put_global_variableL:
Perm;
break;
case Write_named_variableL:
case Put_named_variableL:
Perm;
NamedVar;
break;
case Initialize:
code = _print_init_mask(code, 0);
break;
case Initialize_named:
code = _print_init_mask(code, 1);
break;
case Read_valueTM:
case Read_matched_valueTM:
case Match_next_metaTM:
case Match_metaTM:
case Write_valueTM:
case Write_local_valueTM:
case NextTM:
case ModeTM:
case Push_valueTM:
case Push_local_valueTM:
case Puts_valueTM:
case Write_next_listTM:
Temp;
break;
#if (NREGTMP > 0)
case Read_valueTR:
case Read_matched_valueTR:
case Write_valueTR:
case Write_local_valueTR:
case NextTR:
case ModeTR:
case Push_valueTR:
case Push_local_valueTR:
case Puts_valueTR:
case Push_variableTR:
case Read_variableTR:
case Write_variableTR:
case Push_referenceTR:
TempR;
break;
case Write_named_variableTR:
TempR;
NamedVar;
break;
#endif /* NREGTMP */
case Move3AML:
Am;
Perm;
case Move2AML:
case Put_global_variable2AML:
Am;
Perm;
case MoveAML:
case Get_valueAML:
case Get_matched_valueAML:
case Put_variableAML:
case Put_unsafe_valueAML:
case Put_global_variableAML:
case Read_variable2AML:
case Write_variable2AML:
Am;
Perm;
break;
case MoveNAML:
Integer;
Am;
Perm;
break;
#if (NREGARG > 0)
case MoveARL:
case Get_valueARL:
case Get_matched_valueARL:
case Put_variableARL:
case Put_unsafe_valueARL:
Ar;
Perm;
break;
case Put_named_variableARL:
Ar;
Perm;
NamedVar;
break;
#endif /* NREGARG */
case Put_unsafe_valueAMTM:
case Get_valueAMTM:
case Get_matched_valueAMTM:
Am;
Temp;
break;
case MoveTMAM:
Temp;
Am;
break;
#if (NREGARG > 0)
case MoveARAM:
Ar;
Am;
break;
#endif /* NREGARG */
#if (NREGARG > 0 && NREGTMP > 0)
case MoveTRAR:
TempR;
Ar;
break;
#endif /* NREGARG && NREGTMP */
#if (NREGTMP > 0)
case MoveTRAM:
TempR;
Am;
break;
#endif /* NREGTMP */
#if (NREGARG > 0)
case MoveTMAR:
Temp;
Ar;
break;
#endif /* NREGARG */
#if (NREGTMP > 0)
case Get_valueAMTR:
case Get_matched_valueAMTR:
case MoveAMTR:
Am;
TempR;
break;
#endif /* NREGTMP */
#if (NREGARG > 0)
case Put_unsafe_valueARTM:
case Get_valueARTM:
case Get_matched_valueARTM:
Ar;
Temp;
break;
#endif /* NREGARG */
#if (NREGARG > 0 && NREGTMP > 0)
case Get_valueARTR:
case Get_matched_valueARTR:
case MoveARTR:
Ar;
TempR;
break;
#endif /* NREGARG && NREGTMP */
case Get_variableNAML:
VarOffset;
Am;
Perm;
break;
case Move3LAM:
Perm;
Am;
case Move2LAM:
Perm;
Am;
case MoveLAM:
Perm;
Am;
break;
case MoveNLAM:
Integer;
Perm;
Am;
break;
#if (NREGARG > 0)
case Get_variableNARL:
VarOffset;
Ar;
Perm;
break;
case MoveLAR:
Perm;
Ar;
break;
#endif /* NREGARG */
case MoveAMAM:
case Get_valueAMAM:
case Get_matched_valueAMAM:
Am;
Am;
break;
case Move3LL:
Perm;
Perm;
/* falls through */
case Move2LL:
Perm;
Perm;
/* falls through */
case MoveLL:
case Get_valueLL:
case Write_variable2L:
case Write_local_value2L:
case Push_local_value2L:
case Read_variable2L:
Perm;
Perm;
break;
#if (NREGARG > 0)
case MoveAMAR:
case Get_valueAMAR:
case Get_matched_valueAMAR:
Am;
Ar;
break;
#endif /* NREGARG */
case Get_atom2AM:
Am;
Atom;
case Get_atomAM:
case Out_get_atomAM:
case In_get_atomAM:
case Put_atomAM:
case Put_moduleAM:
Am;
Atom;
break;
#if (NREGARG > 0)
case Get_atomAR:
case Out_get_atomAR:
case In_get_atomAR:
case Put_atomAR:
Ar;
Atom;
break;
#endif /* NREGARG */
case Get_atomintegerAMAM:
Am;
Atom;
Am;
Integer;
break;
case Get_integer2AM:
Am;
Integer;
case Get_integerAM:
case Out_get_integerAM:
case In_get_integerAM:
case Put_integerAM:
Am;
Integer;
break;
#if (NREGARG > 0)
case Get_integerAR:
case Out_get_integerAR:
case In_get_integerAR:
case Put_integerAR:
Ar;
Integer;
break;
#endif /* NREGARG */
case Get_floatAM:
case In_get_floatAM:
case Out_get_floatAM:
case Put_floatAM:
Am;
Float;
break;
#if (NREGARG > 0)
case Get_floatAR:
case In_get_floatAR:
case Out_get_floatAR:
case Put_floatAR:
Ar;
Float;
break;
#endif /* NREGARG */
case Get_stringAM:
case In_get_stringAM:
case Out_get_stringAM:
case Put_stringAM:
Am;
String;
break;
#if (NREGARG > 0)
case Get_stringAR:
case In_get_stringAR:
case Out_get_stringAR:
case Put_stringAR:
Ar;
String;
break;
#endif /* NREGARG */
case Get_structureAM:
case In_get_structureAM:
Am;
Structure;
Code_Label;
break;
case Put_structureAM:
case Out_get_structureAM:
Am;
Structure;
break;
#if (NREGARG > 0)
case Get_structureAR:
case In_get_structureAR:
Ar;
Structure;
Code_Label;
break;
case Out_get_structureAR:
case Put_structureAR:
Ar;
Structure;
break;
#endif /* NREGARG */
case Get_listAM:
case In_get_listAM:
case In_get_metaAM:
Am;
Code_Label;
break;
case Get_metaAM:
Am;
NamedVar;
break;
#if (NREGARG > 0)
case Get_listAR:
case In_get_listAR:
Ar;
Code_Label;
break;
#endif /* NREGARG */
case Read_variableNL:
case Read_referenceNL:
case Write_variableNL:
VarOffset;
Perm;
break;
case Write_named_variableNL:
VarOffset;
Perm;
NamedVar;
break;
case Read_atom2:
Atom;
/* falls through */
case Read_atom:
case Puts_atom:
Atom;
break;
case Read_atominteger:
Atom;
Integer;
break;
case Read_integeratom:
Integer;
Atom;
break;
case Read_integer2:
case Write_integer2:
Integer;
/* falls through */
case Read_integer:
case Write_integer:
case Push_integer:
case Puts_integer:
case Exit_emulator:
case Bounce:
Integer;
break;
case Read_float:
case Write_float:
case Push_float:
case Puts_float:
Float;
break;
case Read_string:
case Write_string:
case Push_string:
case Puts_string:
String;
break;
case Write_did2:
Structure;
/* falls through */
case Write_structure:
case Write_first_structure:
case Write_did:
case Puts_structure:
Structure;
break;
case Write_didinteger:
Structure;
Integer;
break;
case Write_integerdid:
Integer;
Structure;
break;
case Read_structure:
case Read_last_structure:
Structure;
Code_Label;
break;
case Read_meta:
case Read_last_meta:
NamedVar;
case Read_list:
case Read_last_list:
Code_Label;
break;
case Read_structureTM:
case Read_next_structureTM:
case Write_next_structureTMlab:
Structure;
case NextTMlab:
case ModeTMlab:
case Read_listTM:
case Read_next_listTM:
case Write_next_listTMlab:
Temp;
Code_Label;
break;
case Write_next_structureTM:
Structure;
Temp;
break;
case Read_metaTM:
case Read_next_metaTM:
Temp;
NamedVar;
Code_Label;
break;
#if (NREGTMP > 0)
case Read_structureTR:
case Read_next_structureTR:
Structure;
case NextTRlab:
case ModeTRlab:
case Read_listTR:
case Read_next_listTR:
TempR;
Code_Label;
break;
case Get_constantAR:
case Out_get_constantAR:
case In_get_constantAR:
Ar; Const; Consttag;
break;
case Put_constantAR:
Ar; Consttag; Const;
break;
#endif /* NREGTMP */
case Puts_constant:
Consttag; Const;
break;
case Read_constant:
case Write_constant:
case Push_constant:
Const; Consttag;
break;
case Get_constantAM:
case Out_get_constantAM:
case In_get_constantAM:
Am; Const; Consttag;
break;
case Put_constantAM:
Am; Consttag; Const;
break;
case Retry_me_else:
case Retry:
Port;
Code_Label;
break;
case Retry_inline:
Port;
Code_Label;
EnvDesc;
break;
case Trust:
Port;
Code_Label;
Nl;
break;
case Trust_inline:
Port;
Code_Label;
EnvDesc;
Nl;
break;
case Branchs:
VarOffset;
case Branch:
Code_Label;
break;
case Set_bp:
case New_bp:
Code_Label;
break;
case Try_me_else:
Port;
Integer;
Code_Label;
break;
case Retry_me_inline:
Port;
Code_Label;
EnvDesc;
break;
case Trust_me_inline:
Port;
EnvDesc;
break;
case Try_parallel:
{
long nalt;
uword *ptr;
nalt = (long) *code;
Integer;
Integer;
ptr = (uword *) *code++;
if (ptr)
{
do
{
p_fprintf(current_output_, "\n\t\t\t\t");
_print_label((vmcode **) ptr);
ptr++;
} while (nalt--);
}
}
break;
case Retry_seq:
case Try_clause:
Addr;
break;
case GuardL:
VarOffset;
Code_Label;
break;
case Try:
Port;
Integer;
Code_Label;
break;
case Trylab:
Port;
Integer;
Code_Label;
Code_Label;
Nl;
break;
case Retrylab:
Port;
Code_Label;
Code_Label;
Nl;
break;
case Try_me_dynamic:
case Retry_me_dynamic:
#ifdef OLD_DYNAMIC
Integer;
Integer;
Save_Label;
if (*code == SRC_CLAUSE_ARITY)
p_fprintf(current_output_,"SOURCE ");
p_fprintf(current_output_,"%d ",
(*code++) & SRC_CLAUSE_ARITY_MASK);
Code_Label;
#endif
break;
case Push_referenceAM:
Am;
case Allocate:
case Wake_init:
case Space:
case Exits:
case Push_structure:
case Push_reference:
case Push_void_reference:
case Read_attribute:
case Read_voidN:
case Write_voidN:
case Push_voidN:
case Puts_valueG:
case Push_valueG:
VarOffset;
break;
case Gc_testA:
Integer;
case Gc_test:
case Gc:
Integer;
break;
case Cut:
case Cut_single:
VarOffset;
break;
case MoveLAMCallfA:
Perm;
Am;
case CallfA:
case CallA:
Addr;
EnvDesc;
break;
case Put_global_variableAMLCallfA:
Am;
Perm;
Addr;
EnvDesc;
break;
case JmpdAs:
VarOffset;
case JmpA:
case JmpdA:
case ChainA:
case ChaincA:
case ChaindA:
case Meta_jmpA:
Addr;
Nl;
break;
case MoveLAMChainA:
Perm;
Am;
Addr;
Nl;
break;
case MoveLAMCallfP:
Perm;
Am;
case CallfP:
case CallP:
Proc;
case Metacall:
case Handler_call:
case Suspension_call:
case Fail_clause:
EnvDesc;
break;
case Put_global_variableAMLCallfP:
Am;
Perm;
Proc;
EnvDesc;
break;
case Fastcall:
Port;
EnvDesc;
break;
case MoveLAMChainP:
Perm;
Am;
case JmpP:
case JmpdP:
case ChainP:
case ChaincP:
case ChaindP:
Proc;
Nl;
break;
case Ret:
case Retn:
case Retd:
case Retd_nowake:
case Ret_nowake:
case Exit:
case Exitd:
case Exitd_nowake:
case Exitc:
Nl;
break;
case Savecut:
case Neckcut:
case Neckcut_par:
case Deallocate:
case Restore_bp:
case Catch:
case Throw:
case Meta_jmp:
case Suspension_jmp:
case Explicit_jmp:
case Wake:
break;
case Trust_me:
Port;
break;
case SavecutL:
case SoftcutL:
case Dfid_testL:
case Depth:
Perm;
break;
case CutL:
case Push_referenceL:
case Push_init_referenceL:
Perm;
VarOffset;
break;
case CutAMN:
Am;
VarOffset;
break;
case ExtCall:
ExtCallName;
break;
case Escape:
EsuName;
break;
case External:
case External0:
case External1:
case External2:
case External3:
case Call_dynamic:
Proc;
Addr;
break;
case Debug_call:
Proc;
Port;
Atom;
Integer;
Integer;
Integer;
break;
case Debug_call_simple:
Proc;
Port;
Atom;
Integer;
Integer;
Integer;
case Debug_exit_simple_args:
Integer; /* argument descriptor minitags */
Integer; /* offset */
case Debug_exit_simple:
break;
case List_switchL:
Perm;
goto _list_switch_;
case List_switchAM:
Am;
_list_switch_:
if (option & ALS) {
Code_Label;
Code_Label;
Code_Label;
}
break;
#if (NREGARG > 0)
case List_switchAR:
Ar;
if (option & ALS) {
Code_Label;
Code_Label;
Code_Label;
}
break;
#endif /* NREGARG */
#if (NREGARG > 0)
case Atom_switchAR:
Ar;
if (option & ALS) {
Atom_Table2;
Code_Label;
}
break;
#endif /* NREGARG */
case Atom_switchL:
Perm;
goto _atom_switch_;
case Atom_switchAM:
Am;
_atom_switch_:
if (option & ALS) {
Atom_Table2;
Code_Label;
}
break;
case Functor_switchL:
Perm;
goto _functor_switch_;
case Functor_switchAM:
Am;
_functor_switch_:
if (option & ALS) {
Functor_Table2;
Code_Label;
}
break;
#if (NREGARG > 0)
case Functor_switchAR:
Ar;
if (option & ALS) {
Functor_Table2;
Code_Label;
}
break;
#endif /* NREGARG */
case Integer_switchL:
Perm;
goto _integer_switch_;
case Integer_switchAM:
Am;
_integer_switch_:
if (option & ALS) {
Integer_Table2;
Code_Label;
}
break;
#if (NREGARG > 0)
case Integer_switchAR:
Ar;
if (option & ALS) {
Integer_Table2;
Code_Label;
}
break;
#endif /* NREGARG */
case Integer_range_switchL:
Perm;
goto _integer_range_switch_;
case Integer_range_switchAM:
Am;
_integer_range_switch_:
if (option & ALS) {
Integer_Range_Table;
}
break;
case Switch_on_typeL:
Perm;
goto _switch_on_type_;
case Switch_on_typeAM:
Am;
_switch_on_type_:
if (option & ALS)
{
int i;
for (i = 0; i < NTYPES; i++)
{
p_fprintf(current_output_, "\n\t\t\t%-16s",
DidName(tag_desc[i].tag_name));
Code_Label;
}
}
break;
#if (NREGARG > 0)
case Switch_on_typeAR:
Ar;
if (option & ALS)
{
int i;
for (i = 0; i < NTYPES; i++)
{
p_fprintf(current_output_, "\n\t\t\t%d: ", i);
Code_Label;
}
}
break;
#endif /* NREGARG */
case Ress:
VarOffset;
case Res:
Integer;
EnvDesc;
break;
case Continue_after_event:
case Continue_after_event_debug:
case Debug_exit:
case BI_ContDebug:
break;
case Puts_proc:
case Undefined:
Proc;
break;
default:
p_fprintf(current_output_, "Undefined opcode in print_am: %d", *(code - 1));
code = 0;
}
}
(void) ec_newline(current_output_); /* to flush if tty */
return code;
}
ppw(pword *pw) /* print prolog words */
{
int arity = 1;
pword *queue_head = (pword *) 0;
pword *queue_tail = (pword *) 0;
for (;;)
{
char region;
int t = TagType(pw->tag);
if (t < TFORWARD || t > TBUFFER)
t = TUNKNOWN;
if (TG_ORIG <= pw && pw < TG) region = 'g';
else if (SP <= pw && pw < SP_ORIG) region = 'l';
else if (B_ORIG <= pw && pw < B.args) region = 'c';
else if (TT <= (pword **) pw && (pword **) pw < TT_ORIG) region = 't';
else if (address_in_heap(&global_heap, (generic_ptr) pw)) region = 'h';
else region = '?';
p_fprintf(current_output_, "%c 0x%08x: 0x%08x 0x%08x %s ", region,
pw, pw->val.all, pw->tag.all, tag_string[t-TUNKNOWN]);
switch (t)
{
case TFORWARD:
case TMETA:
case TNAME:
if (pw != pw->val.ptr)
{
ec_outfs(current_output_, "--->");
EnQueue_(pw->val.ptr, 1);
}
else
{
ec_outfs(current_output_, IsNamed(pw->tag.kernel) ?
DidName(TagDid(pw->tag.kernel)) : "_");
}
break;
case TVAR_TAG:
if (pw != pw->val.ptr)
{
ec_outfs(current_output_, "--->");
EnQueue_(pw->val.ptr, 1);
}
else
ec_outfs(current_output_, "_");
break;
case TLIST:
EnQueue_(pw->val.ptr, 2);
break;
case TCOMP:
if (pw->val.ptr)
EnQueue_(pw->val.ptr, DidArity(pw->val.ptr->val.did)+1);
break;
case TSTRG:
ec_outfs(current_output_, StringStart(pw->val));
break;
case TSUSP:
break;
case TDE:
break;
case THANDLE:
break;
case TNIL:
break;
case TINT:
p_fprintf(current_output_, "%d", pw->val.nint);
break;
case TDICT:
ec_outfs(current_output_, DidName(pw->val.did));
if (DidArity(pw->val.did))
p_fprintf(current_output_, "/%d", DidArity(pw->val.did));
break;
case TPTR:
break;
case TPROC:
case TEND:
case TVARNUM:
case TGRS:
case TGRL:
case TEXTERN:
case TBUFFER:
break;
case TDBL:
p_fprintf(current_output_, "%f", Dbl(pw->val));
break;
case TBIG:
case TRAT:
default:
if (t >= 0 && t <= NTYPES)
{
(void) tag_desc[t].write(QUOTED, current_output_,
pw->val, pw->tag);
}
break;
}
ec_newline(current_output_);
if (--arity > 0)
{
pw++;
continue;
}
ec_newline(current_output_);
if (EmptyQueue())
break;
DeQueue_(pw, arity);
}
Succeed_;
}
static int
p_tool2(value vi, type ti, value vb, type tb, value vm, type tm)
{
dident di, db;
pri *procb, *proci;
uint32 changed_flags, new_flags;
pri_code_t pricode;
int err;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
Get_Proc_Did(vb, tb, db);
if (DidArity(di) + 1 != DidArity(db))
{
Bip_Error(RANGE_ERROR);
}
if (vm.did == d_.kernel_sepia)
proci = export_procedure(di, vm.did, tm);
else
proci = local_procedure(di, vm.did, tm, PRI_CREATE);
if (!proci)
{
Get_Bip_Error(err);
Bip_Error(err);
}
procb = visible_procedure(db, vm.did, tm, PRI_CREATE);
if (!procb)
{
Get_Bip_Error(err);
Bip_Error(err);
}
/* Incompatbilities of being a TOOL */
if (DynamicProc(proci))
{
Bip_Error(INCONSISTENCY);
}
/* Incompatbilities of being a tool body */
if (PriFlags(procb) & TOOL)
{
Bip_Error(INCONSISTENCY);
}
changed_flags = TOOL|TOOL_INHERIT_FLAGS|DEBUG_DB|SYSTEM;
new_flags = TOOL
|(TOOL_INHERIT_FLAGS & procb->flags)
|(GlobalFlags & DBGCOMP ? DEBUG_DB : 0)
|(vm.did == d_.kernel_sepia ? SYSTEM : 0);
err = pri_compatible_flags(proci, changed_flags, new_flags);
if (err != PSUCCEED)
{
Bip_Error(err);
}
pri_change_flags(proci, changed_flags & ~CODETYPE, new_flags & ~CODETYPE);
Pri_Set_Reference(procb);
proci->mode = procb->mode;
pricode.vmc = _tool_code(procb, GlobalFlags & DBGCOMP);
pri_define_code(proci, procb->flags & CODETYPE, pricode);
/* make sure the tool body is exported or reexported, so it can
* be invoked with a qualified call with lookup module vm */
if (!PriAnyExp(procb) && !PriWillExport(procb))
{
if (PriScope(procb) == IMPORT)
procb = reexport_procedure(db, vm.did, tm, PriHomeModule(procb));
else
procb = export_procedure(db, vm.did, tm);
if (!procb)
{
Get_Bip_Error(err);
Bip_Error(err);
}
}
Succeed_;
}
pword *
term_to_dbformat(pword *parg, dident mod)
{
pword **save_tt = TT;
register word arity = 1, len;
register word curr_offset = 0, top_offset = 2; /* in 'word's */
register pword *queue_tail = (pword *) 0;
pword *queue_head = (pword *) 0;
register pword *pw;
register char *dest, *stop;
pword *header;
temp_area meta_attr;
int flag = 0;
Temp_Create(meta_attr, 4 * ATTR_IO_TERM_SIZE * sizeof(pword));
header = TG;
dest = (char *) (header + 1) + 4; /* space for the TBUFFER pword and for
* the external format header */
for(;;) /* handle <arity> consecutive pwords, starting at <parg> */
{
do /* handle the pword pointed to by parg */
{
pw = parg;
/* I need here a slightly modified version of Dereference_(pw)
* that stops also at MARKed words. Not very nice, I know.
*/
while (IsRef(pw->tag) && !(pw->tag.kernel & MARK) && !IsSelfRef(pw))
pw = pw->val.ptr;
Reserve_Space(6);
if (pw->tag.kernel & MARK)
{
if (SameTypeC(pw->tag,TDE)) /* a suspension */
{
Store_Byte(Tag(pw->tag.kernel));
Store_Int32((pw[SUSP_FLAGS].tag.kernel & ~MARK));
if (SuspDead(pw)) {
curr_offset += Words(SUSP_HEADER_SIZE-1);
parg += SUSP_HEADER_SIZE-1;
arity -= SUSP_HEADER_SIZE-1;
} else {
Store_Byte(SuspPrio(pw) + (SuspRunPrio(pw) << 4));
curr_offset += Words(SUSP_GOAL-1);
parg += SUSP_GOAL-1;
arity -= SUSP_GOAL-1;
}
}
else if (pw->val.nint == curr_offset) /* a nonstd variable */
{
Store_Byte(Tag(pw->tag.kernel));
Store_Int(pw->val.nint);
if (!IsNamed(pw->tag.kernel))
{
Store_Byte(0);
}
else /* store its name */
{
dident vdid = TagDid(pw->tag.kernel);
len = DidLength(vdid);
Store_Int(len);
Reserve_Space(len);
Store_String(len, DidName(vdid));
}
}
else /* just a reference to an already encountered variable */
{
Store_Byte(Tag(TVAR_TAG));
Store_Int(pw->val.nint);
}
}
else switch (TagType(pw->tag))
{
case TINT:
#if SIZEOF_CHAR_P > 4
if (pw->val.nint < WSUF(-2147483648) || WSUF(2147483648) <= pw->val.nint)
{
/* store as a bignum (to be readable on 32bit machines) */
len = tag_desc[pw->tag.kernel].string_size(pw->val, pw->tag, 1);
Store_Byte(TBIG);
Store_Int(len);
Reserve_Space(len+1);
stop = dest+len;
dest += tag_desc[pw->tag.kernel].to_string(pw->val, pw->tag,
dest, 1);
while (dest <= stop) /* pad and terminate */
*dest++ = 0;
break;
}
#endif
Store_Byte(TINT);
#ifdef OLD_FORMAT
Store_Int32(pw->val.nint);
#else
Store_Int(pw->val.nint);
#endif
break;
case TNIL:
Store_Byte(Tag(pw->tag.kernel));
break;
case TDICT:
len = DidLength(pw->val.did);
Store_Byte(TDICT);
Store_Int(DidArity(pw->val.did));
Store_Int(len);
Reserve_Space(len);
Store_String(len, DidName(pw->val.did));
break;
case TDBL:
{
ieee_double d;
d.as_dbl = Dbl(pw->val);
Store_Byte(TDBL);
Store_Byte(sizeof(double)-1); /* backward compat */
Reserve_Space(sizeof(double));
Store_Int32(d.as_struct.mant1);
Store_Int32(d.as_struct.mant0);
break;
}
case TIVL:
{
ieee_double dlwb, dupb;
dlwb.as_dbl = IvlLwb(pw->val.ptr);
dupb.as_dbl = IvlUpb(pw->val.ptr);
Store_Byte(TIVL);
Reserve_Space(2*sizeof(double));
Store_Int32(dlwb.as_struct.mant1);
Store_Int32(dlwb.as_struct.mant0);
Store_Int32(dupb.as_struct.mant1);
Store_Int32(dupb.as_struct.mant0);
break;
}
case TSTRG:
len = StringLength(pw->val);
Store_Byte(TSTRG);
Store_Int(len);
Reserve_Space(len);
Store_String(len, StringStart(pw->val));
break;
case TVAR_TAG: /* standard variable */
Store_Byte(Tag(TVAR_TAG));
Store_Int(curr_offset);
Trail_(pw);
pw->val.nint = curr_offset;
pw->tag.kernel |= MARK;
break;
case TNAME:
case TUNIV:
Store_Byte(Tag(TVAR_TAG));
Store_Int(top_offset);
Trail_Tag(pw);
pw->val.nint = top_offset;
pw->tag.kernel |= MARK;
top_offset += 2;
EnQueue_(pw, 1, 0);
break;
case TMETA:
Store_Byte(Tag(TVAR_TAG));
Store_Int(top_offset);
Trail_Tag(pw);
pw->val.nint = top_offset;
pw->tag.kernel |= MARK;
top_offset += 4;
EnQueue_(pw, 2, QUEUE_MASK_META);
break;
case TSUSP:
Store_Byte(Tag(TSUSP));
pw = pw->val.ptr;
if (pw->tag.kernel & MARK) /* not the first encounter */
{
Store_Int(pw->val.nint);
}
else
{
Store_Int(top_offset);
Trail_Pword(pw);
pw->tag.kernel |= MARK;
pw->val.nint = top_offset;
if (SuspDead(pw))
{
top_offset += Words(SUSP_HEADER_SIZE); /* for TDE */
EnQueue_(pw, SUSP_HEADER_SIZE, 0);
}
else
{
top_offset += Words(SUSP_SIZE); /* for TDE */
EnQueue_(pw, SUSP_SIZE, 0);
}
}
break;
case TLIST:
Store_Byte(Tag(TLIST));
Store_Int(top_offset);
top_offset += 4;
EnQueue_(pw->val.ptr, 2, 0);
break;
case TCOMP:
Store_Byte(Tag(TCOMP));
Store_Int(top_offset);
if (flag) {
pword pw_out;
(void) transf_meta_out(pw->val, pw->tag,
(pword *) TempAlloc(meta_attr, ATTR_IO_TERM_SIZE * sizeof(pword)),
D_UNKNOWN, &pw_out);
pw = pw_out.val.ptr;
len = 1 + DidArity(pw->val.did);
EnQueue_(pw, len, 0);
} else {
len = 1 + DidArity(pw->val.ptr->val.did);
EnQueue_(pw->val.ptr, len, 0);
}
top_offset += 2*len;
break;
default:
if (TagType(pw->tag) >= 0 && TagType(pw->tag) <= NTYPES)
{
len = tag_desc[TagType(pw->tag)].string_size(pw->val, pw->tag, 1);
Store_Byte(Tag(pw->tag.kernel));
Store_Int(len);
Reserve_Space(len+1);
stop = dest+len;
dest += tag_desc[TagType(pw->tag)].to_string(pw->val, pw->tag,
dest, 1);
while (dest <= stop) /* pad and terminate */
*dest++ = 0;
}
else
{
p_fprintf(current_err_,
"bad type in term_to_dbformat: 0x%x\n",
pw->tag.kernel);
}
break;
}
curr_offset += Words(1);
++parg;
} while (--arity);
if (EmptyQueue())
break;
DeQueue_(parg, arity, flag);
}
/* # bytes of external representation */
Store_Byte(0); /* add a terminating 0 */
Set_Buffer_Size(header, dest - (char*) header - sizeof(pword));
header->tag.kernel = TBUFFER;
Align(); /* align the global stack pointer */
TG = (pword *) dest;
dest = (char *) (header + 1); /* fill in the external format header */
Store_Int32(top_offset); /* (size of term after restoring) */
Untrail_Variables(save_tt);
Temp_Destroy(meta_attr);
return header;
}
