static void _update_def_use(pri *def, pri *use) { /* Note on memory management of code blocks: * Undefined-code blocks are never shared between descriptors, * so don't copy pointers to them. * Defined-code is shared and pointed to from all descriptors. */ if ((PriCodeType(use) == VMCODE) && !(PriFlags(use) & CODE_DEFINED)) { if (PriFlags(def) & CODE_DEFINED) { remove_procedure(use); /* undefined -> defined */ use->code = def->code; } else if (!use->code.vmc) /* undefined -> undefined */ _pri_init_vmcode(use, PriFlags(def)&TOOL); /* else keep undefined-code field */ } else { if ((PriCodeType(def) == VMCODE) && !(PriFlags(def) & CODE_DEFINED)) _pri_init_vmcode(use, PriFlags(def)&TOOL); /* defined -> undefined */ else use->code = def->code; /* defined -> defined */ } use->module_ref = def->module_def; use->mode = def->mode; use->trans_function = def->trans_function; use->flags = (use->flags & DESCRIPTOR_FLAGS) | (def->flags & COMMON_FLAGS); }
void print_pri(pri *pd) { switch(PriScope(pd)) { case QUALI: p_fprintf(current_output_, "QUALI "); break; case LOCAL: p_fprintf(current_output_, "LOCAL "); break; case EXPORT: p_fprintf(current_output_, "EXPORT "); break; case IMPORT: p_fprintf(current_output_, "IMPORT "); break; case DEFAULT: p_fprintf(current_output_, "DEFAUL "); break; case IMPEXP: p_fprintf(current_output_, "IMPEXP "); break; default: p_fprintf(current_output_, "?????? "); break; } p_fprintf(current_output_, "in %12s from %12s", DidName(pd->module_def), pd->module_ref? DidName(pd->module_ref) : "UNKNOWN"); p_fprintf(current_output_, " %c%c%c %c %c%c%c%c%c %c%c%c%c%c %c%c%c %01x p%d", pd->flags&SYSTEM ? 'S' : '_', pd->flags&NOREFERENCE ? 'N' : '_', pd->flags&CODE_DEFINED ? 'C' : '_', pd->flags&TO_EXPORT ? 'X' : '_', pd->flags&PROC_PARALLEL ? 'P' : '_', pd->flags&PROC_DEMON ? 'D' : '_', pd->flags&TOOL ? 'T' : '_', pd->flags&AUTOLOAD ? 'A' : '_', pd->flags&PROC_DYNAMIC ? 'Y' : '_', pd->flags&DEBUG_TR ? 'T' : '_', pd->flags&DEBUG_SP ? 'P' : '_', pd->flags&DEBUG_SK ? 'K' : '_', pd->flags&DEBUG_DB ? 'D' : '_', pd->flags&DEBUG_ST ? 'S' : '_', (pd->flags&(CODETYPE)) == VMCODE ? 'v' : 'f', (pd->flags&(ARGPASSING)) == ARGFIXEDWAM ? 'a' : (pd->flags&(ARGPASSING)) == ARGFLEXWAM ? 'f' : '?', pd->flags&EXTERN ? 'X' : '_', pd->flags&(UNIFTYPE), PriPriority(pd)); if (!PriCode(pd)) p_fprintf(current_output_, " null_code"); else if ((PriCodeType(pd) == VMCODE) && IsUndefined(PriCode(pd))) p_fprintf(current_output_, " undef_code"); else p_fprintf(current_output_, " 0x%x", PriCode(pd)); ec_newline(current_output_); }
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; }
/* 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 }
/* _tool_code(proc, debug) - makes the code for a tool interface */ static vmcode * _tool_code(pri *procb, int debug) { vmcode *code; vmcode *save; if (PriCodeType(procb) & VMCODE) { Allocate_Default_Procedure(3 + (debug?DEBUG_LENGTH:0), PriDid(procb)); save = code; if (debug) { Store_3(Debug_call, procb, CALL_PORT|FIRST_CALL|LAST_CALL); Store_4d(d_.empty,0,0,0); } Store_i(JmpdP); Store_d(procb); Store_i(Code_end); return save; } else { return procb->code.vmc; /* use the body's code */ } }