void op_indpat(mval *v, mval *dst)
{
bool rval;
mstr *obj, object;
oprtype x;
error_def(ERR_INDMAXNEST);
MV_FORCE_STR(v);
if (!(obj = cache_get(indir_pattern, &v->str)))
{
comp_init(&v->str);
source_column = 1; /* to coordinate with scanner redirection*/
rval = compile_pattern(&x,window_token == TK_ATSIGN);
if (comp_fini(rval, &object, OC_IRETMVAL, &x, v->str.len))
{
cache_put(indir_pattern, &v->str, &object);
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
}
}
else
{
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(obj);
}
}
int gtmsource_comm_init(void)
{
/* Initialize communication stuff */
struct linger disable_linger = {0, 0};
char error_string[1024];
int err_status;
if (FD_INVALID != gtmsource_sock_fd) /* Initialization done already */
return(0);
/* Create the socket used for communicating with secondary */
if (FD_INVALID == (gtmsource_sock_fd = socket(AF_INET, SOCK_STREAM, 0)))
{
err_status = ERRNO;
SNPRINTF(error_string, SIZEOF(error_string), "Error with source server socket create : %s", STRERROR(err_status));
rts_error(VARLSTCNT(6) ERR_REPLCOMM, 0, ERR_TEXT, 2, RTS_ERROR_STRING(error_string));
return(-1);
}
/* A connection breakage should get rid of the socket */
if (-1 == setsockopt(gtmsource_sock_fd, SOL_SOCKET, SO_LINGER, (const void *)&disable_linger, SIZEOF(disable_linger)))
{
err_status = ERRNO;
SNPRINTF(error_string, SIZEOF(error_string), "Error with source server socket disable linger : %s",
STRERROR(err_status));
rts_error(VARLSTCNT(6) ERR_REPLCOMM, 0, ERR_TEXT, 2, RTS_ERROR_STRING(error_string));
}
return(0);
}
/* For routine name given, return routine header address if rhd not already set */
rhdtyp *op_rhdaddr(mval *name, rhdtyp *rhd)
{
mval routine;
mident_fixed routname;
rhdtyp *answer;
if (NULL != rhd)
answer = rhd;
else
{
MV_FORCE_STR(name);
routine = *name;
routine.str.len = (MAX_MIDENT_LEN < routine.str.len ? MAX_MIDENT_LEN : routine.str.len);
memcpy(&routname.c[0], routine.str.addr, routine.str.len);
routine.str.addr = (char *)&routname.c[0];
if ((NULL == rtn_names) || (NULL == (answer = find_rtn_hdr(&routine.str)))) /* Note assignment */
{ /* Initial check for rtn_names is so we avoid the call to find_rtn_hdr() if we have just
* unlinked all modules as find_rtn_hdr() does not deal well with an empty rtn table.
*/
op_zlink(&routine, NULL);
answer = find_rtn_hdr(&routine.str);
if (NULL == answer)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, name->str.len, name->str.addr,
ERR_ZLMODULE, 2, strlen(&zlink_mname.c[0]), &zlink_mname);
# if defined (__alpha) && defined (__vms)
answer = answer->linkage_ptr;
if (NULL == answer)
rts_error(VARLSTCNT(8) ERR_ZLINKFILE, 2, name->str.len, name->str.addr,
ERR_ZLMODULE, 2, strlen(&zlink_mname.c[0]), zlink_mname.c);
# endif
}
}
return answer;
}
void copy_stack_frame(void)
{
register stack_frame *sf;
unsigned char *msp_save;
msp_save = msp;
sf = (stack_frame *) (msp -= SIZEOF(stack_frame));
if (msp <= stackwarn)
{
if (msp <= stacktop)
{
msp = msp_save;
rts_error(VARLSTCNT(1) ERR_STACKOFLOW);
} else
rts_error(VARLSTCNT(1) ERR_STACKCRIT);
}
assert(msp < stackbase);
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
*sf = *frame_pointer;
sf->old_frame_pointer = frame_pointer;
sf->flags = 0; /* Don't propagate special flags */
sf->for_ctrl_stack = NULL;
frame_pointer = sf;
DBGEHND((stderr, "copy_stack_frame: Added stackframe at addr 0x"lvaddr" old-msp: 0x"lvaddr" new-msp: 0x"lvaddr"\n",
sf, msp_save, msp));
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
}
void ojdefimage (mstr *image)
{
static mstr imagebuf = {0, 0};
int4 status;
unsigned char local_buff[MAX_FILSPC_LEN];
short iosb[4];
unsigned short length;
struct
{
item_list_3 le[1];
int4 terminator;
} item_list;
if (!imagebuf.addr)
{
item_list.le[0].buffer_length = MAX_FILSPC_LEN;
item_list.le[0].item_code = JPI$_IMAGNAME;
item_list.le[0].buffer_address = local_buff;
item_list.le[0].return_length_address = &length;
item_list.terminator = 0;
status = sys$getjpi (0, 0, 0, &item_list, &iosb[0], 0, 0);
if (!(status & 1))
rts_error(VARLSTCNT(1) status);
sys$synch (efn_immed_wait, &iosb[0]);
if (!(iosb[0] & 1))
rts_error(VARLSTCNT(1) iosb[0]);
imagebuf.addr = malloc(length);
imagebuf.len = length;
memcpy(imagebuf.addr, local_buff, length);
}
*image = imagebuf;
return;
}
/* Lookup an external function. Return function address if success, NULL otherwise.
* package_handle - DLL handle returned by fgn_getpak
* entry_name - symbol name to be looked up
* msgtype - message severity of the errors reported if any.
* Note: If msgtype is SUCCESS, errors are not issued. It is useful if the callers are not
* interested in message report and not willing to have condition handler overhead (eg. zro_search).
*/
fgnfnc fgn_getrtn(void_ptr_t package_handle, mstr *entry_name, int msgtype)
{
void_ptr_t sym_addr;
char_ptr_t dummy_err_str;
void *short_sym_addr;
char err_str[MAX_ERRSTR_LEN]; /* needed as util_out_print doesn't handle 64bit pointers */
error_def(ERR_DLLNORTN);
error_def(ERR_TEXT);
if (!(sym_addr = dlsym(package_handle, entry_name->addr)))
{
if (SUCCESS != msgtype)
{
assert(!(msgtype & ~SEV_MSK));
COPY_DLLERR_MSG;
rts_error(VARLSTCNT(8) MAKE_MSG_TYPE(ERR_DLLNORTN, msgtype), 2, LEN_AND_STR(entry_name->addr),
ERR_TEXT, 2, LEN_AND_STR(err_str));
}
} else
{ /* Tru64 - dlsym() is bound to return short pointer because of ld -taso flag used for GT.M */
#ifdef __osf__
short_sym_addr = sym_addr;
if (short_sym_addr != sym_addr)
{
sym_addr = NULL;
/* always report an error irrespective of msgtype - since this code should never
* have executed and/or the DLL might need to be rebuilt with 32-bit options */
rts_error(VARLSTCNT(8) ERR_DLLNORTN, 2, LEN_AND_STR(entry_name->addr),
ERR_TEXT, 2, LEN_AND_LIT("Symbol is loaded above the lower 31-bit address space"));
}
#endif
}
return (fgnfnc)sym_addr;
}
void op_indfun(mval *v, mint code, mval *dst)
{
bool rval;
mstr *obj, object;
oprtype x;
unsigned char argcode;
error_def(ERR_INDMAXNEST);
argcode = (unsigned char)code;
assert(UCHAR_MAX >= code); /* if not, the assignment to argcode is lossy */
assert(indir_opcode[argcode]);
MV_FORCE_STR(v);
if (!(obj = cache_get(argcode, &v->str)))
{
comp_init(&v->str);
rval = (*indir_fcn[argcode])(&x, indir_opcode[argcode]);
if (!comp_fini(rval, &object, OC_IRETMVAL, &x, v->str.len))
return;
cache_put(argcode, &v->str, &object);
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
return;
}
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(obj);
return;
}
/*
* ------------------------------------------
* Hang the process for a specified time.
*
* Goes to sleep for a positive value.
* Any caught signal will terminate the sleep
* following the execution of that signal's catching routine.
*
* Arguments:
* num - time to sleep
*
* Return:
* none
* ------------------------------------------
*/
void op_hang(mval* num)
{
int ms;
#ifdef VMS
uint4 time[2];
int4 efn_mask, status;
error_def(ERR_SYSCALL);
#endif
ms = 0;
MV_FORCE_NUM(num);
if (num->mvtype & MV_INT)
{
if (0 < num->m[1])
{
assert(MV_BIAS >= 1000); /* if formats change overflow may need attention */
ms = num->m[1] * (1000 / MV_BIAS);
}
} else if (0 == num->sgn) /* if sign is not 0 it means num is negative */
ms = mval2i(num) * 1000; /* too big to care about fractional amounts */
if (ms)
{
UNIX_ONLY(hiber_start(ms);)
VMS_ONLY(
time[0] = -time_low_ms(ms);
time[1] = -time_high_ms(ms) - 1;
efn_mask = (1 << efn_outofband | 1 << efn_timer);
if (SS$_NORMAL != (status = sys$setimr(efn_timer, &time, NULL, &time, 0)))
rts_error(VARLSTCNT(8) ERR_SYSCALL, 5, RTS_ERROR_LITERAL("$setimr"), CALLFROM, status);
if (SS$_NORMAL != (status = sys$wflor(efn_outofband, efn_mask)))
rts_error(VARLSTCNT(8) ERR_SYSCALL, 5, RTS_ERROR_LITERAL("$wflor"), CALLFROM, status);
)
if (outofband)
void op_trollback(int rb_levels) /* rb_levels -> # of transaction levels by which we need to rollback */
{
short newlevel;
tp_region *tr;
gd_region *save_cur_region; /* saved copy of gv_cur_region before tp_clean_up/tp_incr_clean_up modifies it */
gd_region *curreg;
sgmnt_addrs *csa;
error_def(ERR_TLVLZERO);
error_def(ERR_TROLLBK2DEEP);
error_def(ERR_INVROLLBKLVL);
if (0 == dollar_tlevel)
rts_error(VARLSTCNT(1) ERR_TLVLZERO);
if (0 > rb_levels && dollar_tlevel < -rb_levels)
rts_error(VARLSTCNT(4) ERR_TROLLBK2DEEP, 2, -rb_levels, dollar_tlevel);
else if (dollar_tlevel <= rb_levels)
rts_error(VARLSTCNT(4) ERR_INVROLLBKLVL, 2, rb_levels, dollar_tlevel);
newlevel = (0 > rb_levels) ? dollar_tlevel + rb_levels : rb_levels;
/* The DBG_CHECK_GVTARGET_CSADDRS_IN_SYNC macro is used at various points in the database code to check that
* gv_target and cs_addrs are in sync. This is because op_gvname relies on this in order to avoid a gv_bind_name
* function call (if incoming key matches gv_currkey from previous call, it uses gv_target and cs_addrs right
* away instead of recomputing them). We want to check that here as well. The only exception is if we were
* interrupted in the middle of TP transaction by an external signal which resulted in us terminating right away.
* In this case, we are guaranteed not to make a call to op_gvname again (because we are exiting) so it is ok
* not to do this check.
*/
DEBUG_ONLY(
if (!process_exiting)
{
DBG_CHECK_GVTARGET_CSADDRS_IN_SYNC;
}
)
void change_fhead_timer(char *timer_name, sm_int_ptr_t timer_address, int default_time, bool zero_is_ok)
/* default_time is in milliseconds */
{
uint4 status, value;
error_def(ERR_TIMRBADVAL);
default_time = default_time * TIMER_SCALE;
timer_address[1] = 0;
status = cli_present((char *)timer_name);
if (status == CLI_NEGATED)
timer_address[0] = zero_is_ok ? 0 : default_time;
else if (status == CLI_PRESENT)
{
status = cli_get_time((char *)timer_name, &value);
if (TRUE == status)
{
if ((ONE_HOUR < value) || ((0 == value) && (FALSE == zero_is_ok)))
rts_error(VARLSTCNT(1) ERR_TIMRBADVAL);
else /* the above error is of type GTM-I- */
timer_address[0] = value;
} else
rts_error(VARLSTCNT(1) ERR_TIMRBADVAL);
}
return;
}
boolean_t iosocket_listen(io_desc *iod, unsigned short len)
{
d_socket_struct *dsocketptr;
socket_struct *socketptr;
char *errptr;
int4 errlen;
error_def(ERR_SOCKLISTEN);
error_def(ERR_TEXT);
error_def(ERR_LQLENGTHNA);
error_def(ERR_SOCKACTNA);
error_def(ERR_CURRSOCKOFR);
error_def(ERR_LISTENPASSBND);
if (MAX_LISTEN_QUEUE_LENGTH < len)
{
rts_error(VARLSTCNT(3) ERR_LQLENGTHNA, 1, len);
return FALSE;
}
assert(iod->type == gtmsocket);
dsocketptr = (d_socket_struct *)iod->dev_sp;
socketptr = dsocketptr->socket[dsocketptr->current_socket];
if (dsocketptr->current_socket >= dsocketptr->n_socket)
{
rts_error(VARLSTCNT(4) ERR_CURRSOCKOFR, 2, dsocketptr->current_socket, dsocketptr->n_socket);
return FALSE;
}
if ((socketptr->state != socket_bound) || (socketptr->passive != TRUE))
{
rts_error(VARLSTCNT(1) ERR_LISTENPASSBND);
return FALSE;
}
dsocketptr->dollar_key[0] = '\0';
/* establish a queue of length len for incoming connections */
if (-1 == tcp_routines.aa_listen(socketptr->sd, len))
{
errptr = (char *)STRERROR(errno);
errlen = STRLEN(errptr);
rts_error(VARLSTCNT(6) ERR_SOCKLISTEN, 0, ERR_TEXT, 2, errlen, errptr);
return FALSE;
}
socketptr->state = socket_listening;
len = sizeof(LISTENING) - 1;
memcpy(&dsocketptr->dollar_key[0], LISTENING, len);
dsocketptr->dollar_key[len++] = '|';
memcpy(&dsocketptr->dollar_key[len], socketptr->handle, socketptr->handle_len);
len += socketptr->handle_len;
dsocketptr->dollar_key[len++] = '|';
SPRINTF(&dsocketptr->dollar_key[len], "%d", socketptr->local.port);
return TRUE;
}
void op_indglvn(mval *v,mval *dst)
{
bool rval;
mstr *obj, object;
oprtype x;
lv_val *a;
icode_str indir_src;
lv_val *lv;
var_tabent targ_key;
ht_ent_mname *tabent;
error_def(ERR_INDMAXNEST);
error_def(ERR_UNDEF);
MV_FORCE_STR(v);
indir_src.str = v->str;
indir_src.code = indir_glvn;
if (NULL == (obj = cache_get(&indir_src)))
{
if (valid_mname(&v->str))
{
targ_key.var_name = v->str;
COMPUTE_HASH_MNAME(&targ_key);
tabent = lookup_hashtab_mname(&curr_symval->h_symtab, &targ_key);
assert(NULL == tabent || NULL != tabent->value);
if (!tabent || !MV_DEFINED(&((lv_val *)tabent->value)->v))
{
if (undef_inhibit)
{
*dst = literal_null;
return;
}
else
rts_error(VARLSTCNT(4) ERR_UNDEF, 2, v->str.len, v->str.addr);
}
a = (lv_val *)tabent->value;
*dst = a->v;
return;
}
comp_init(&v->str);
rval = glvn(&x);
if (comp_fini(rval, &object, OC_IRETMVAL, &x, v->str.len))
{
indir_src.str.addr = v->str.addr;
cache_put(&indir_src, &object);
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
}
}
else
{
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(obj);
}
}
void comp_indr (mstr *obj)
{
stack_frame *sf;
unsigned char *fix, *fix_base, *tmps, *syms, *save_msp;
int tempsz, vartabsz, fixup_cnt;
INTPTR_T *vp;
ihdtyp *rtnhdr;
error_def(ERR_STACKOFLOW);
error_def(ERR_STACKCRIT);
save_msp = msp;
sf = (stack_frame *)(msp -= sizeof(stack_frame));
rtnhdr = (ihdtyp *)obj->addr;
/* Check that our cache_entry pointer is in proper alignment with us */
assert(rtnhdr->indce->obj.addr == (char *)rtnhdr);
tempsz = ROUND_UP2(rtnhdr->temp_size, SIZEOF(char *));
tmps = msp -= tempsz;
vartabsz = rtnhdr->vartab_len;
vartabsz *= sizeof(mval *);
/* Check that our vars and friends can fit on this stack */
if ((msp -= vartabsz) <= stackwarn)
{
if (msp <= stacktop)
{
msp = save_msp;
rts_error(VARLSTCNT(1) ERR_STACKOFLOW);
}
else
rts_error(VARLSTCNT(1) ERR_STACKCRIT);
}
syms = msp;
*sf = *frame_pointer;
sf->old_frame_pointer = frame_pointer;
sf->type = 0;
sf->temps_ptr = tmps;
if (tempsz)
memset(tmps, 0, tempsz);
sf->l_symtab = (mval **)syms;
sf->vartab_len = rtnhdr->vartab_len;
if (vartabsz)
memset(syms, 0, vartabsz);
sf->vartab_ptr = (char *)rtnhdr + rtnhdr->vartab_off;
sf->temp_mvals = rtnhdr->temp_mvals;
/* Code starts just past the literals that were fixed up and past the validation and hdr offset fields */
sf->mpc = (unsigned char *)rtnhdr + rtnhdr->fixup_vals_off + (rtnhdr->fixup_vals_num * sizeof(mval));
GTM64_ONLY(sf->mpc = (unsigned char *)ROUND_UP2((UINTPTR_T)sf->mpc, SECTION_ALIGN_BOUNDARY));
sf->mpc = sf->mpc + (2 * sizeof(INTPTR_T)); /*Account for hdroffset and MAGIC_VALUE*/
sf->flags = SFF_INDCE; /* We will be needing cleanup for this frame */
DEBUG_ONLY(
vp = (INTPTR_T *)sf->mpc;
vp--;
assert((GTM_OMAGIC << 16) + OBJ_LABEL == *vp);
vp--;
assert((unsigned char*)rtnhdr == (unsigned char *)vp + *vp);
);
int gtm_init()
{
rhdtyp *base_addr;
unsigned char *transfer_addr;
error_def(ERR_CITPNESTED);
error_def(ERR_CIMAXLEVELS);
if (!gtm_startup_active)
{ /* call-in invoked from C as base. GT.M hasn't been started up yet. */
image_type = GTM_IMAGE;
gtm_env_init(); /* read in all environment variables */
err_init(stop_image_conditional_core);
cli_lex_setup(0, NULL);
/* Initialize msp to the maximum so if errors occur during GT.M startup below,
* the unwind logic in gtmci_ch() will get rid of the whole stack. */
msp = (unsigned char*)-1;
}
ESTABLISH_RET(gtmci_ch, mumps_status);
if (!gtm_startup_active)
{ /* GT.M is not active yet. Create GT.M startup environment */
invocation_mode = MUMPS_CALLIN;
init_gtm();
gtm_savetraps(); /* nullify default $ZTRAP handling */
assert(gtm_startup_active);
assert(frame_pointer->flags & SFF_CI);
nested_level = 1;
}
else if (!(frame_pointer->flags & SFF_CI))
{ /* Nested call-in: setup a new CI environment (SFF_CI frame on top of base-frame) */
/* Mark the beginning of the new stack so that initialization errors in
* call-in frame do not unwind entries of the previous stack (see gtmci_ch).*/
fgncal_stack = msp;
/* Report if condition handlers stack may overrun during this callin level.
* Every underlying level can not have more than 2 active condition handlers,
* plus extra MAX_HANDLERS are reserved for this level. */
if (chnd_end - ctxt <= MAX_HANDLERS)
rts_error(VARLSTCNT(3) ERR_CIMAXLEVELS, 1, nested_level);
/* Disallow call-ins within a TP boundary since TP restarts are not supported
* currently across nested call-ins. When we implement TP restarts across call-ins,
* this error needs be changed to a Warning or Notification */
if (0 < dollar_tlevel)
rts_error(VARLSTCNT(1) ERR_CITPNESTED);
base_addr = make_cimode();
transfer_addr = PTEXT_ADR(base_addr);
gtm_init_env(base_addr, transfer_addr);
SET_CI_ENV(ci_ret_code_exit);
gtmci_isv_save();
nested_level++;
}
/* Now that GT.M is initialized. Mark the new stack pointer (msp) so that errors
* while executing an M routine do not unwind stack below this mark. It important that
* the call-in frames (SFF_CI), that hold nesting information (eg. $ECODE/$STACK data
* of the previous stack), are kept from being unwound. */
fgncal_stack = msp;
REVERT;
return 0;
}
void comp_indr(mstr *obj)
{
stack_frame *sf;
unsigned char *fix, *fix_base, *tmps, *syms, *save_msp;
int tempsz, vartabsz, fixup_cnt, zapsz;
INTPTR_T *vp;
ihdtyp *rtnhdr;
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
save_msp = msp;
sf = (stack_frame *)(msp -= SIZEOF(stack_frame));
rtnhdr = (ihdtyp *)obj->addr;
/* Check that our cache_entry pointer is in proper alignment with us */
assert(rtnhdr->indce->obj.addr == (char *)rtnhdr);
tempsz = ROUND_UP2(rtnhdr->temp_size, SIZEOF(char *));
tmps = msp -= tempsz;
vartabsz = rtnhdr->vartab_len;
vartabsz *= SIZEOF(ht_ent_mname *);
/* Check that our vars and friends can fit on this stack */
if ((msp -= vartabsz) <= stackwarn)
{
if (msp <= stacktop)
{
msp = save_msp;
rts_error(VARLSTCNT(1) ERR_STACKOFLOW);
} else
rts_error(VARLSTCNT(1) ERR_STACKCRIT);
}
syms = msp;
*sf = *frame_pointer;
sf->old_frame_pointer = frame_pointer;
sf->type = 0;
sf->temps_ptr = tmps;
sf->l_symtab = (ht_ent_mname **)syms;
sf->vartab_len = rtnhdr->vartab_len;
if (zapsz = (vartabsz + tempsz)) /* Note assignment */
memset(syms, 0, zapsz); /* Zap temps and symtab together */
sf->vartab_ptr = (char *)rtnhdr + rtnhdr->vartab_off;
sf->temp_mvals = rtnhdr->temp_mvals;
/* Code starts just past the literals that were fixed up and past the validation and hdr offset fields */
sf->mpc = (unsigned char *)rtnhdr + rtnhdr->fixup_vals_off + (rtnhdr->fixup_vals_num * SIZEOF(mval));
/* IA64 required SECTION_ALIGN_BOUNDARY alignment (16 bytes). ABS 2008/12
* This has been carried forward to other 64bit platfoms without problems
*/
GTM64_ONLY(sf->mpc = (unsigned char *)ROUND_UP2((UINTPTR_T)sf->mpc, SECTION_ALIGN_BOUNDARY));
sf->mpc = sf->mpc + (2 * SIZEOF(INTPTR_T)); /* Account for hdroffset and MAGIC_VALUE */
sf->flags = SFF_INDCE; /* We will be needing cleanup for this frame */
sf->ret_value = NULL;
sf->dollar_test = -1; /* initialize it with -1 for indication of not yet being used */
DEBUG_ONLY(
vp = (INTPTR_T *)sf->mpc;
assert(NULL != vp);
vp--;
assert((GTM_OMAGIC << 16) + OBJ_LABEL == *vp);
vp--;
assert((unsigned char*)rtnhdr == (unsigned char *)vp + *vp);
);
void op_indlvarg(mval *v, mval *dst)
{
bool rval;
mstr *obj, object;
oprtype x;
triple *ref;
icode_str indir_src;
error_def(ERR_INDMAXNEST);
error_def(ERR_VAREXPECTED);
MV_FORCE_STR(v);
if (v->str.len < 1)
rts_error(VARLSTCNT(1) ERR_VAREXPECTED);
if (valid_mname(&v->str))
{
*dst = *v;
dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
return;
}
if (*v->str.addr == '@')
{
indir_src.str = v->str;
indir_src.code = indir_lvarg;
if (NULL == (obj = cache_get(&indir_src)))
{
object.addr = v->str.addr;
object.len = v->str.len;
comp_init(&object);
if (rval = indirection(&x))
{
ref = newtriple(OC_INDLVARG);
ref->operand[0] = x;
x = put_tref(ref);
}
if (comp_fini(rval, &object, OC_IRETMVAL, &x, object.len))
{
indir_src.str.addr = v->str.addr;
cache_put(&indir_src, &object);
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
return;
}
} else
{
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(obj);
return;
}
}
rts_error(VARLSTCNT(1) ERR_VAREXPECTED);
}
/* this has to be maintained in parallel with unw_retarg(), the unwind with a return argument (extrinisic quit) routine */
void op_unwind(void)
{
mv_stent *mvc;
error_def(ERR_STACKUNDERFLO);
error_def(ERR_TPQUIT);
if (tp_pointer && tp_pointer->fp <= frame_pointer)
rts_error(VARLSTCNT(1) ERR_TPQUIT);
/* Note that error_ret() should be invoked only after the rts_error() of TPQUIT.
* This is so the TPQUIT error gets noted down in $ECODE (which will not happen if error_ret() is called before).
*/
if (!skip_error_ret)
{
INVOKE_ERROR_RET_IF_NEEDED;
} else
{
if (NULL != error_frame)
{
assert(error_frame >= frame_pointer);
if (error_frame <= frame_pointer)
NULLIFY_ERROR_FRAME; /* ZGOTO to frame level lower than primary error level cancels error mode */
}
skip_error_ret = FALSE; /* reset at the earliest point although caller (goframes()) does reset it just in
* case an error occurs before we return to the caller */
}
assert(msp <= stackbase && msp > stacktop);
assert(mv_chain <= (mv_stent *)stackbase && mv_chain > (mv_stent *)stacktop);
assert(frame_pointer <= (stack_frame*)stackbase && frame_pointer > (stack_frame *)stacktop);
/* See if unwinding an indirect frame */
IF_INDR_FRAME_CLEANUP_CACHE_ENTRY(frame_pointer);
for (mvc = mv_chain; mvc < (mv_stent *)frame_pointer; )
{
unw_mv_ent(mvc);
mvc = (mv_stent *)(mvc->mv_st_next + (char *)mvc);
}
if (is_tracing_on)
(*unw_prof_frame_ptr)();
mv_chain = mvc;
msp = (unsigned char *)frame_pointer + sizeof(stack_frame);
if (msp > stackbase)
rts_error(VARLSTCNT(1) ERR_STACKUNDERFLO);
frame_pointer = frame_pointer->old_frame_pointer;
if (NULL != zyerr_frame && frame_pointer > zyerr_frame)
zyerr_frame = NULL;
if (frame_pointer)
{
if (frame_pointer < (stack_frame *)msp || frame_pointer > (stack_frame *)stackbase ||
frame_pointer < (stack_frame *)stacktop)
rts_error(VARLSTCNT(1) ERR_STACKUNDERFLO);
}
return;
}
/* returns the truth value based on the sense indicated by 'negate'.
* If negate is FALSE (i.e. in regular mode),
* returns TRUE if the env variable/logical log is defined and evaluates to "TRUE" (or part thereof),
* or "YES" (or part thereof), or a non zero integer
* returns FALSE otherwise
* If negate is TRUE(i.e. in negative mode),
* returns TRUE if the env variable/logical log is defined and evaluates to "FALSE" (or part thereof),
* or "NO" (or part thereof), or a zero integer
* returns FALSE otherwise
*/
boolean_t logical_truth_value(mstr *log, boolean_t negate, boolean_t *is_defined)
{
int4 status;
mstr tn;
char buf[1024];
boolean_t zero, is_num;
int index;
error_def(ERR_LOGTOOLONG);
error_def(ERR_TRNLOGFAIL);
tn.addr = buf;
if (NULL != is_defined)
*is_defined = FALSE;
if (SS_NORMAL == (status = TRANS_LOG_NAME(log, &tn, buf, SIZEOF(buf), dont_sendmsg_on_log2long)))
{
if (NULL != is_defined)
*is_defined = TRUE;
if (tn.len <= 0)
return FALSE;
for (is_num = TRUE, zero = TRUE, index = 0; index < tn.len; index++)
{
if (!ISDIGIT_ASCII(buf[index]))
{
is_num = FALSE;
break;
}
zero = (zero && ('0' == buf[index]));
}
if (!negate)
{ /* regular mode */
return (!is_num ? (0 == STRNCASECMP(buf, LOGICAL_TRUE, MIN(STR_LIT_LEN(LOGICAL_TRUE), tn.len)) ||
0 == STRNCASECMP(buf, LOGICAL_YES, MIN(STR_LIT_LEN(LOGICAL_YES), tn.len)))
: !zero);
} else
{ /* negative mode */
return (!is_num ? (0 == STRNCASECMP(buf, LOGICAL_FALSE, MIN(STR_LIT_LEN(LOGICAL_FALSE), tn.len)) ||
0 == STRNCASECMP(buf, LOGICAL_NO, MIN(STR_LIT_LEN(LOGICAL_NO), tn.len)))
: zero);
}
} else if (SS_NOLOGNAM == status)
return (FALSE);
# ifdef UNIX
else if (SS_LOG2LONG == status)
{
rts_error(VARLSTCNT(5) ERR_LOGTOOLONG, 3, log->len, log->addr, SIZEOF(buf) - 1);
return (FALSE);
}
# endif
else
{
rts_error(VARLSTCNT(5) ERR_TRNLOGFAIL, 2, log->len, log->addr, status);
return (FALSE);
}
}
/* Routine to:
* (1) To turn off the MV_RETARG flag in the mval returned from the M function call.
* (2) To verify the flag was ON in the first place, else this is not a return value.
* (3) To verify the MV_ALIASCONT flag IS on which would signify a QUIT * was done.
* To not do this constitutes an error and means QUIT * was NOT done as is
* required to create an alias on the caller side.
*/
void op_exfunretals(mval *retval)
{
unsigned short savtyp;
savtyp = retval->mvtype;
retval->mvtype &= ~MV_RETARG;
if (0 == (MV_RETARG & savtyp))
rts_error(VARLSTCNT(1) ERR_QUITARGREQD);
if (0 == (MV_ALIASCONT & savtyp))
rts_error(VARLSTCNT(1) ERR_ALIASEXPECTED);
assert(NULL != alias_retarg);
}
void new_stack_frame(rhdtyp *rtn_base, unsigned char *context, unsigned char *transfer_addr)
{
register stack_frame *sf;
unsigned char *msp_save;
unsigned int x1, x2;
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
msp_save = msp;
sf = (stack_frame *)(msp -= SIZEOF(stack_frame));
if (msp <= stackwarn)
{
if (msp <= stacktop)
{
msp = msp_save;
rts_error(VARLSTCNT(1) ERR_STACKOFLOW);
} else
rts_error(VARLSTCNT(1) ERR_STACKCRIT);
}
assert((unsigned char *)msp < stackbase);
sf->old_frame_pointer = frame_pointer;
sf->rvector = rtn_base;
sf->vartab_ptr = (char *)VARTAB_ADR(rtn_base);
sf->vartab_len = sf->rvector->vartab_len;
sf->ctxt = context;
sf->mpc = transfer_addr;
sf->flags = 0;
sf->for_ctrl_stack = NULL;
#ifdef HAS_LITERAL_SECT
sf->literal_ptr = (int4 *)LITERAL_ADR(rtn_base);
#endif
sf->temp_mvals = sf->rvector->temp_mvals;
msp -= x1 = rtn_base->temp_size;
sf->temps_ptr = msp;
sf->type = SFT_COUNT;
msp -= x2 = rtn_base->vartab_len * SIZEOF(ht_ent_mname *);
sf->l_symtab = (ht_ent_mname **)msp;
if (msp <= stackwarn)
{
if (msp <= stacktop)
{
msp = msp_save;
rts_error(VARLSTCNT(1) ERR_STACKOFLOW);
} else
rts_error(VARLSTCNT(1) ERR_STACKCRIT);
}
assert(msp < stackbase);
memset(msp, 0, x1 + x2);
frame_pointer = sf;
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
DBGEHND((stderr, "new_stack_frame: Added stackframe at addr 0x"lvaddr" old-msp: 0x"lvaddr" new-msp: 0x"lvaddr"\n",
sf, msp_save, msp));
return;
}
int op_readfl(mval *v, int4 length, int4 timeout)
{
int4 stat; /* status */
size_t cnt, insize, outsize;
char *start_ptr, *save_ptr;
unsigned char *temp_ch;
error_def(ERR_TEXT);
error_def(ERR_RDFLTOOSHORT);
error_def(ERR_RDFLTOOLONG);
if (timeout < 0)
timeout = 0;
if (length <= 0)
rts_error(VARLSTCNT(1) ERR_RDFLTOOSHORT);
if (length > MAX_STRLEN)
rts_error(VARLSTCNT(1) ERR_RDFLTOOLONG);
assert(stringpool.free >= stringpool.base);
assert(stringpool.free <= stringpool.top);
if (stringpool.free + length + ESC_LEN > stringpool.top)
stp_gcol(length + ESC_LEN);
v->mvtype = MV_STR;
v->str.addr = (char *)stringpool.free;
v->str.len = 0;
active_device = io_curr_device.in;
stat = (io_curr_device.in->disp_ptr->readfl)(v, length, timeout);
stringpool.free += v->str.len;
assert((int4)v->str.len <= length);
assert(stringpool.free <= stringpool.top);
if (DEFAULT_CODE_SET != active_device->in_code_set)
{
cnt = insize = outsize = v->str.len;
assert(stringpool.free >= stringpool.base);
assert(stringpool.free <= stringpool.top);
if (cnt > stringpool.top - stringpool.free)
stp_gcol(cnt);
temp_ch = stringpool.free;
save_ptr = v->str.addr;
start_ptr = (char *)temp_ch;
stringpool.free += cnt;
assert(stringpool.free >= stringpool.base);
assert(stringpool.free <= stringpool.top);
ICONVERT(active_device->input_conv_cd, (unsigned char **)&(v->str.addr), &insize, &temp_ch, &outsize);
v->str.addr = start_ptr;
}
active_device = 0;
if (NO_M_TIMEOUT != timeout)
return (stat);
return FALSE;
}
/* The third parameter is dummy to keep the inteface same as op_open */
int mu_op_open(mval *v, mval *p, int t, mval *mspace)
{
char buf1[MAX_TRANS_NAME_LEN]; /* buffer to hold translated name */
io_log_name *naml; /* logical record for passed name */
io_log_name *tl; /* logical record for translated name */
int4 stat; /* status */
mstr tn; /* translated name */
error_def(LP_NOTACQ); /* bad license */
error_def(ERR_LOGTOOLONG);
MV_FORCE_STR(v);
MV_FORCE_STR(p);
if (mspace)
MV_FORCE_STR(mspace);
if (t < 0)
t = 0;
assert((unsigned char)*p->str.addr < n_iops);
naml = get_log_name(&v->str, INSERT);
if (naml->iod != 0)
tl = naml;
else
{
# ifdef NOLICENSE
licensed= TRUE ;
# else
CRYPT_CHKSYSTEM;
if (!licensed || LP_CONFIRM(lid,lkid)==LP_NOTACQ)
{
licensed= FALSE ;
}
# endif
switch(stat = TRANS_LOG_NAME(&v->str, &tn, &buf1[0], sizeof(buf1), dont_sendmsg_on_log2long))
{
case SS_NORMAL:
tl = get_log_name(&tn, INSERT);
break;
case SS_NOLOGNAM:
tl = naml;
break;
case SS_LOG2LONG:
rts_error(VARLSTCNT(5) ERR_LOGTOOLONG, 3, v->str.len, v->str.addr, sizeof(buf1) - 1);
break;
default:
rts_error(VARLSTCNT(1) stat);
}
}
stat = mu_open_try(naml, tl, p, mspace);
return (stat);
}
void op_fnzbitxor(mval *dst, mval *bitstr1, mval *bitstr2)
{
int n, str_len1, str_len2, new_str_len;
unsigned char *byte_1, *byte_n;
unsigned char *byte1_1, *byte1_n, byte1_len;
unsigned char *byte2_1, *byte2_n, byte2_len;
error_def(ERR_INVBITSTR);
MV_FORCE_STR(bitstr1);
MV_FORCE_STR(bitstr2);
if (!bitstr1->str.len || !bitstr2->str.len)
rts_error(VARLSTCNT(1) ERR_INVBITSTR);
byte1_len = *(unsigned char *)bitstr1->str.addr;
str_len1 = (bitstr1->str.len - 1) * 8;
if (7 < byte1_len)
rts_error(VARLSTCNT(1) ERR_INVBITSTR);
byte2_len = *(unsigned char *)bitstr2->str.addr;
str_len2 = (bitstr2->str.len -1) * 8;
if (7 < byte2_len)
rts_error(VARLSTCNT(1) ERR_INVBITSTR);
if (str_len1 - byte1_len > str_len2 - byte2_len)
new_str_len = str_len2 - byte2_len;
else
new_str_len = str_len1 - byte1_len;
n = (new_str_len + 7)/8 ;
if (stringpool.top - stringpool.free < n + 1)
stp_gcol(n + 1);
byte_1 = (unsigned char *)stringpool.free;
*byte_1 = n * 8 - new_str_len;
byte1_1 = (unsigned char *)bitstr1->str.addr;
byte2_1 = (unsigned char *)bitstr2->str.addr;
for(byte_n = byte_1 + 1, byte1_n = byte1_1 + 1, byte2_n = byte2_1 + 1 ;
byte_n <= (byte_1 + n); byte_n++, byte1_n++, byte2_n++)
{
*byte_n = *byte1_n ^ *byte2_n;
}
*--byte_n &= mask[*byte_1];
dst->mvtype = MV_STR;
dst->str.addr = (char *)stringpool.free;
dst->str.len = n + 1;
stringpool.free += n + 1;
}
static bool lke_process(int argc)
{
bool flag = FALSE;
int res;
static int save_stderr = SYS_STDERR;
ESTABLISH_RET(util_ch, TRUE);
if (util_interrupt)
rts_error(VARLSTCNT(1) ERR_CTRLC);
if (SYS_STDERR != save_stderr) /* necesary in case of rts_error */
close_fileio(&save_stderr);
assert(SYS_STDERR == save_stderr);
func = 0;
util_interrupt = 0;
if (argc < 2)
display_prompt();
if ( EOF == (res = parse_cmd()))
{
if (util_interrupt)
{
rts_error(VARLSTCNT(1) ERR_CTRLC);
REVERT;
return TRUE;
}
else
{
REVERT;
return FALSE;
}
} else if (res)
{
if (1 < argc)
{
REVERT;
rts_error(VARLSTCNT(4) res, 2, LEN_AND_STR(cli_err_str));
} else
gtm_putmsg(VARLSTCNT(4) res, 2, LEN_AND_STR(cli_err_str));
}
if (func)
{
flag = open_fileio(&save_stderr); /* save_stderr = SYS_STDERR if -output option not present */
func();
if (flag)
close_fileio(&save_stderr);
assert(SYS_STDERR == save_stderr);
}
REVERT;
return(1 >= argc);
}
/*
* Description:
* Grab ftok semaphore on replication instance file
* Release all replication semaphores for the instance (both jnlpool and recvpool)
* Release ftok semaphore
* Parameters:
* Return Value: TRUE, if succsessful
* FALSE, if fails.
*/
boolean_t mu_replpool_remove_sem(boolean_t immediate)
{
char *instname;
gd_region *replreg;
unix_db_info *udi;
unsigned int full_len;
int save_errno;
error_def(ERR_REPLFTOKSEM);
error_def(ERR_REPLACCSEM);
/*
* JNL POOL SEMAPHORES
*/
replreg = jnlpool.jnlpool_dummy_reg;
assert(replreg);
instname = (char *)replreg->dyn.addr->fname;
full_len = replreg->dyn.addr->fname_len;
if (0 == full_len)
return TRUE;
if (!ftok_sem_get(replreg, TRUE, REPLPOOL_ID, immediate))
rts_error(VARLSTCNT(4) ERR_REPLFTOKSEM, 2, full_len, instname);
if (0 != remove_sem_set(SOURCE))
{
save_errno = REPL_SEM_ERRNO;
if (!ftok_sem_release(replreg, TRUE, TRUE))
gtm_putmsg(VARLSTCNT(4) ERR_REPLFTOKSEM, 2, full_len, instname);
udi = FILE_INFO(replreg);
rts_error(VARLSTCNT(6) ERR_REPLACCSEM, 3, udi->semid, full_len, instname, save_errno);
}
repl_inst_jnlpool_reset();
/*
* RECV POOL SEMAPHORES
*/
replreg = recvpool.recvpool_dummy_reg;
assert(replreg);
if (0 != remove_sem_set(RECV))
{
save_errno = REPL_SEM_ERRNO;
if (!ftok_sem_release(replreg, TRUE, TRUE))
gtm_putmsg(VARLSTCNT(4) ERR_REPLFTOKSEM, 2, full_len, instname);
udi = FILE_INFO(replreg);
rts_error(VARLSTCNT(6) ERR_REPLACCSEM, 3, udi->semid, full_len, instname, save_errno);
}
repl_inst_recvpool_reset();
if (!ftok_sem_release(replreg, TRUE, immediate))
rts_error(VARLSTCNT(4) ERR_REPLFTOKSEM, 2, full_len, instname);
return TRUE;
}
uint4 trans_numeric(mstr *log, boolean_t *is_defined, boolean_t ignore_errors)
{
/* return
* - 0 on error if ignore_errors is set (otherwise error is raised and no return is made) or
* if logical/envvar is undefined.
* - an unsigned int containing the numeric value (or as much as could be determined) from
* the logical/envvar string value (up to the first non-numeric digit. Characters accepted
* are those read by the strtoul() function.
*/
int4 status;
uint4 value;
mstr tn;
char buf[MAX_TRANS_NAME_LEN], *endptr;
error_def(ERR_LOGTOOLONG);
error_def(ERR_TRNLOGFAIL);
*is_defined = FALSE;
if (SS_NORMAL == (status = TRANS_LOG_NAME(log, &tn, buf, SIZEOF(buf),
ignore_errors ? do_sendmsg_on_log2long : dont_sendmsg_on_log2long)))
{ /* Translation was successful */
*is_defined = TRUE;
assert(tn.len < SIZEOF(buf));
endptr = tn.addr + tn.len;
*endptr = '\0';
value = (uint4)STRTOUL(buf, &endptr, 0); /* Base 0 allows base 10, 0x or octal input */
/* At this point, if '\0' == *endptr, the entire string was successfully consumed as
a numeric string. If not, endptr has been updated to point to the errant chars. We
currently have no clients who care about this so there is no expansion on this but
this could be added at this point. For now we just return whatever numeric value
(if any) was gleened..
*/
return value;
} else if (SS_NOLOGNAM == status) /* Not defined */
return 0;
if (!ignore_errors)
{ /* Only give errors if we can handle them */
# ifdef UNIX
if (SS_LOG2LONG == status)
rts_error(VARLSTCNT(5) ERR_LOGTOOLONG, 3, log->len, log->addr, SIZEOF(buf) - 1);
else
# endif
rts_error(VARLSTCNT(5) ERR_TRNLOGFAIL, 2, log->len, log->addr, status);
}
return 0;
}
void gtcm_open_cmerrlog(void)
{
int len;
mstr lfn1, lfn2;
char lfn_path[MAX_TRANS_NAME_LEN + 1];
char new_lfn_path[MAX_TRANS_NAME_LEN + 1];
int new_len;
uint4 ustatus;
int4 rval;
FILE *new_file;
error_def(ERR_TEXT);
if (0 != (len = STRLEN(gtcm_gnp_server_log)))
{
lfn1.addr = gtcm_gnp_server_log;
lfn1.len = len;
} else
{
lfn1.addr = GTCM_GNP_CMERR_FN;
lfn1.len = sizeof(GTCM_GNP_CMERR_FN) - 1;
}
rval = TRANS_LOG_NAME(&lfn1, &lfn2, lfn_path, sizeof(lfn_path), do_sendmsg_on_log2long);
if (rval == SS_NORMAL || rval == SS_NOLOGNAM)
{
lfn_path[lfn2.len] = 0;
rename_file_if_exists(lfn_path, lfn2.len, new_lfn_path, &new_len, &ustatus);
new_file = Fopen(lfn_path, "a");
if (NULL != new_file)
{
gtcm_errfile = TRUE;
if (gtcm_errfs)
fclose(gtcm_errfs);
gtcm_errfs = new_file;
if (dup2(fileno(gtcm_errfs), 1) < 0)
{
rts_error(VARLSTCNT(5) ERR_TEXT, 2, LEN_AND_LIT("Error on dup2 of stdout"), errno);
}
if (dup2(fileno(gtcm_errfs), 2) < 0)
{
rts_error(VARLSTCNT(5) ERR_TEXT, 2, LEN_AND_LIT("Error on dup2 of stderr"), errno);
}
}
else
fprintf(stderr, "Unable to open %s : %s\n", lfn_path, STRERROR(errno));
} else
fprintf(stderr, "Unable to resolve %s : return value = %d\n", GTCM_GNP_CMERR_FN, rval);
gtcm_firsterr = FALSE;
}
void op_zmess(int4 errnum, ...)
{
va_list var;
int4 status, cnt, faocnt;
unsigned short m_len;
unsigned char faostat[4];
unsigned char msgbuff[MAX_MSG_SIZE + 1];
unsigned char buff[FAO_BUFFER_SPACE];
int4 fao[MAX_FAO_PARMS + 1];
$DESCRIPTOR(d_sp, msgbuff);
error_def(ERR_TPRETRY);
VAR_START(var, errnum);
va_count(cnt);
cnt--;
status = sys$getmsg(errnum, &m_len, &d_sp, 0, &faostat[0]);
if ((status & 1) && m_len)
{
buff[m_len] = 0;
memset(&fao[0], 0, SIZEOF(fao));
faocnt = (cnt ? faostat[1] : cnt);
faocnt = (faocnt > MAX_FAO_PARMS ? MAX_FAO_PARMS : faocnt);
if (faocnt)
faocnt = mval2fao(msgbuff, var, &fao[0], cnt, faocnt, buff, buff + SIZEOF(buff));
va_end(var);
if (faocnt != -1)
{
/* Currently there are a max of 20 fao parms (MAX_FAO_PARMS) allowed, hence passing upto fao_list[19].
* An assert is added to ensure this code is changed whenever the macro MAX_FAO_PARMS is changed.
* The # of arguments passed below should change accordingly.
*/
assert(MAX_FAO_PARMS == 20);
if (ERR_TPRETRY == errnum)
{ /* A TP restart is being signalled. Set t_fail_hist just like a TRESTART command would */
op_trestart_set_cdb_code();
}
rts_error(VARLSTCNT(MAX_FAO_PARMS + 2) errnum, faocnt, fao[0], fao[1], fao[2], fao[3], fao[4], fao[5],
fao[6], fao[7], fao[8], fao[9], fao[10], fao[11], fao[12], fao[13], fao[14], fao[15], fao[16],
fao[17], fao[18], fao[19]);
}
return;
} else
{
va_end(var);
rts_error(VARLSTCNT(1) status);
}
}
/* Routine to NEW a special intrinsic variable. Note that gtm_newinstrinsic(),
which actually does the dirty work, may shift the stack to insert the mv_stent
which saves the old value. Because of this, any caller of this module MUST
reload the stack pointers to the M stackframe. This is normally taken care of
by opp_newintrinsic().
*/
void op_newintrinsic(int intrtype)
{
mval *intrinsic;
boolean_t stored_explicit_null;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
switch(intrtype)
{
case SV_ZTRAP:
# ifdef GTM_TRIGGER
if (0 < gtm_trigger_depth)
rts_error(VARLSTCNT(1) ERR_NOZTRAPINTRIG);
# endif
/* Due to the potential intermix of $ETRAP and $ZTRAP, we put a condition on the
explicit NEWing of these two special variables. If "the other" trap handler
definition is not null (meaning this handler is not in control) then we will
ignore the NEW. This is necessary for example when a frame with $ZT set calls
a routine that NEWs and sets $ET. When it unwinds, we don't want it to pop off
the old "null" value for $ET which then triggers the nulling out of our current
$ZT value. Note that op_svput no longer calls this routine for "implicit" NEWs
but calls directly to gtm_newintrinsic instead.
*/
if (dollar_etrap.str.len)
{
assert(FALSE == ztrap_explicit_null);
return;
}
assert(!ztrap_explicit_null || (0 == dollar_ztrap.str.len));
DEBUG_ONLY(stored_explicit_null = FALSE;)
if (ztrap_explicit_null && (0 == dollar_ztrap.str.len))
{
DEBUG_ONLY(stored_explicit_null = TRUE;)
/* routine exposed to call-in user to exit from active GT.M environment */
int gtm_exit()
{
error_def(ERR_INVGTMEXIT);
if (!gtm_startup_active)
return 0; /* GT.M environment not setup yet - quietly return */
ESTABLISH_RET(gtmci_ch, mumps_status);
assert(NULL != frame_pointer);
/* Do not allow gtm_exit() to be invoked from external calls */
if (!(SFF_CI & frame_pointer->flags) || !(MUMPS_CALLIN & invocation_mode) || (1 < nested_level))
rts_error(VARLSTCNT(1) ERR_INVGTMEXIT);
/* Now get rid of the whole M stack - end of GT.M environment */
while (NULL != frame_pointer)
{
while (NULL != frame_pointer && !(frame_pointer->flags & SFF_CI))
op_unwind();
if (NULL != frame_pointer)
{ /* unwind the current invocation of call-in environment */
assert(frame_pointer->flags & SFF_CI);
ci_ret_code_quit();
}
}
gtm_exit_handler(); /* rundown all open database resource */
REVERT;
gtm_startup_active = FALSE;
return 0;
}
