pri * pri_home(pri *pd) { type tm; if (pd->module_ref == pd->module_def) return pd; if (pd->module_ref == D_UNKNOWN) { Set_Bip_Error(NOENTRY); return 0; } tm.kernel = ModuleTag(pd->module_ref); return visible_procedure(pd->did, pd->module_ref, tm, PRI_DONTIMPORT); }
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; }
/* tool_(Name/Arity, SourceModule) set the tool flag of Name/Arity in SourceModule. */ static int p_tool1(value vi, type ti, value vm, type tm) { #if 0 dident di; pri *proci, *pd; int err; Check_Module(tm, vm); Get_Proc_Did(vi, ti, di); proci = visible_procedure(di, vm.did, tm, PRI_CREATE); if (!proci) { Get_Bip_Error(err); Bip_Error(err); } if (proci->flags & TOOL) { Succeed_; } err = pri_compatible_flags(proci, TOOL, TOOL); if (err != PSUCCEED) { Bip_Error(err); } pri_change_flags(proci, TOOL, TOOL); if (PriCodeType(proci) == VMCODE) { /* keep the old code, e.g. autoload_code... */ /* update the code header, important for saving the arguments * in the event mechanism */ Incr_Code_Arity(PriCode(proci)); } Succeed_; #else Bip_Error(NOT_IMPLEMENTED); #endif }
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_; }