int op_fngvget2(mval *res, mval *val, mval *optional)
{
MV_FORCE_DEFINED(optional);
if (MV_DEFINED(val))
*res = *val;
else
*res = *optional;
assert(0 == (res->mvtype & MV_ALIASCONT)); /* Should be no alias container flag in this global */
return TRUE;
}
void op_fno2(lv_val *src,mval *key,mval *dst,mval *direct)
{
error_def(ERR_ORDER2);
MV_FORCE_DEFINED(key);
MV_FORCE_NUM(direct);
if (!MV_IS_INT(direct) || (direct->m[1] != 1*MV_BIAS && direct->m[1] != -1*MV_BIAS))
rts_error(VARLSTCNT(1) ERR_ORDER2);
else
{ if (direct->m[1] == 1*MV_BIAS)
op_fnorder(src,key,dst);
else
op_fnzprevious(src,key,dst);
}
}
int mval2fao(
char *message, /* text of message in fao format */
va_list pfao, /* argument list of caller */
UINTPTR_T *outparm, /* array of resulting fao parameters */
int mcount, int fcount, /* mvalcount and faocount */
char *bufbase, char *buftop) /* buffer space for !AC and !AS */
{
char *buf;
int i, parmcnt, num;
mval *fao;
fao = va_arg(pfao, mval *);
parmcnt = 0;
buf = bufbase;
for ( ; mcount && parmcnt < fcount; )
{
MV_FORCE_DEFINED(fao);
while (*message != '!')
message++;
for (i=0;(*++message > 47) && (*message < 58);i++) /* a length for the fao parameter */
;
switch (*message++)
{
case '/':
case '_':
case '^':
case '!': break;
case 'A': MV_FORCE_STR(fao);
switch(*message++)
{
/* ascii counted string */ case 'C':
if ((fao)->str.len > 256 || (fao)->str.len < 0)
return -1;
if (buf + (fao)->str.len + 1 >= buftop)
return -1;
*buf++ = (fao)->str.len;
memcpy(buf, (fao)->str.addr, (fao)->str.len);
buf += (fao)->str.len;
break;
/* len,addr string, '.' filled */ case 'F':
/* len,addr string */ case 'D':
if (parmcnt + 2 > fcount)
return parmcnt;
outparm[parmcnt++] = (unsigned int)(fao)->str.len;
outparm[parmcnt++] = (UINTPTR_T)(fao)->str.addr;
break;
/* ascii string descriptor */ case 'S':
if (buf + sizeof(desc_struct) >= buftop)
return -1;
((desc_struct *)buf)->len = (fao)->str.len;
((desc_struct *)buf)->addr = (fao)->str.addr;
outparm[parmcnt++] = (UINTPTR_T)buf;
buf += sizeof(desc_struct);
break;
default: return -1;
}
fao = va_arg(pfao, mval *);
mcount--;
break;
/* octal number */ case 'O':
/* hex number */ case 'X':
/* signed number */ case 'S':
num = MV_FORCE_INT(fao);
switch(*message++)
{
case 'B': outparm[parmcnt++] = (UINTPTR_T)num;
break;
case 'W': outparm[parmcnt++] = (UINTPTR_T)num;
break;
case 'L': outparm[parmcnt++] = (UINTPTR_T)num;
break;
default: return -1;
}
fao = va_arg(pfao, mval *);
mcount--;
break;
/* zero filled num */ case 'Z':
/* unsigned num */ case 'U':
num = MV_FORCE_INT(fao);
switch(*message++)
{
case 'B': outparm[parmcnt++] = (UINTPTR_T)num;
break;
case 'W': outparm[parmcnt++] = (UINTPTR_T)num;
break;
case 'L': outparm[parmcnt++] = (UINTPTR_T)num;
break;
default: return -1;
}
fao = va_arg(pfao, mval *);
mcount--;
break;
default: return -1;
}
}
return parmcnt;
}
/* This has to be maintained in parallel with op_unwind(), the unwind without a return argument (intrinsic quit) routine. */
int unw_retarg(mval *src, boolean_t alias_return)
{
mval ret_value, *trg;
boolean_t got_ret_target;
stack_frame *prevfp;
lv_val *srclv, *srclvc, *base_lv;
symval *symlv, *symlvc;
int4 srcsymvlvl;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
assert(NULL == alias_retarg);
alias_retarg = NULL;
DBGEHND_ONLY(prevfp = frame_pointer);
if (tp_pointer && tp_pointer->fp <= frame_pointer)
rts_error(VARLSTCNT(1) ERR_TPQUIT);
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);
got_ret_target = FALSE;
/* Before we do any unwinding or even verify the existence of the return var, check to see if we are returning
* an alias (or container). We do this now because (1) alias returns don't need to be defined and (2) the returning
* item could go out of scope in the unwinds so we have to bump the returned item's reference counts NOW.
*/
if (!alias_return)
{ /* Return of "regular" value - Verify it exists */
MV_FORCE_DEFINED(src);
ret_value = *src;
ret_value.mvtype &= ~MV_ALIASCONT; /* Make sure alias container of regular return does not propagate */
} else
{ /* QUIT *var or *var(indx..) syntax was used - see which one it was */
assert(NULL != src);
srclv = (lv_val *)src; /* Since can never be an expression, this relationship is guaranteed */
if (!LV_IS_BASE_VAR(srclv))
{ /* Have a potential container var - verify */
if (!(MV_ALIASCONT & srclv->v.mvtype))
rts_error(VARLSTCNT(1) ERR_ALIASEXPECTED);
ret_value = *src;
srclvc = (lv_val *)srclv->v.str.addr;
assert(LV_IS_BASE_VAR(srclvc)); /* Verify base var */
assert(srclvc->stats.trefcnt >= srclvc->stats.crefcnt);
assert(1 <= srclvc->stats.crefcnt); /* Verify is existing container ref */
base_lv = LV_GET_BASE_VAR(srclv);
symlv = LV_GET_SYMVAL(base_lv);
symlvc = LV_GET_SYMVAL(srclvc);
MARK_ALIAS_ACTIVE(MIN(symlv->symvlvl, symlvc->symvlvl));
DBGRFCT((stderr, "unw_retarg: Returning alias container 0x"lvaddr" pointing to 0x"lvaddr" to caller\n",
src, srclvc));
} else
{ /* Creating a new alias - create a container to pass back */
memcpy(&ret_value, &literal_null, SIZEOF(mval));
ret_value.mvtype |= MV_ALIASCONT;
ret_value.str.addr = (char *)srclv;
srclvc = srclv;
MARK_ALIAS_ACTIVE(LV_SYMVAL(srclv)->symvlvl);
DBGRFCT((stderr, "unw_retarg: Returning alias 0x"lvaddr" to caller\n", srclvc));
}
INCR_TREFCNT(srclvc);
INCR_CREFCNT(srclvc); /* This increment will be reversed if this container gets put into an alias */
/* We have a slight chicken-and-egg problem now. The mv_stent unwind loop below may pop a symbol table thus
* destroying the lv_val in our container. To prevent this, we need to locate the parm block before the symval is
* unwound and set the return value and alias_retarg appropriately so the symtab unwind logic called by
* unw_mv_ent() can work any necessary relocation magic on the return var.
*/
trg = get_ret_targ(NULL);
if (NULL != trg)
{
*trg = ret_value;
alias_retarg = trg;
got_ret_target = TRUE;
} /* else fall into below which will raise the NOTEXTRINSIC error */
}
/* Note: we are unwinding uncounted (indirect) frames here to allow the QUIT command to have indirect arguments
* and thus be executed by commarg in an indirect frame. By unrolling the indirect frames here we get back to
* the point where we can find where to put the quit value.
*/
unwind_nocounts();
assert(frame_pointer && (frame_pointer->type & SFT_COUNT));
while (mv_chain < (mv_stent *)frame_pointer)
{
msp = (unsigned char *)mv_chain;
unw_mv_ent(mv_chain);
POP_MV_STENT();
}
if (0 <= frame_pointer->dollar_test)
dollar_truth = (boolean_t)frame_pointer->dollar_test;
/* Now that we have unwound the uncounted frames, we should be left with a counted frame that
* contains some ret_value, NULL or not. If the value is non-NULL, let us restore the $TEST
* value from that frame as well as update *trg for non-alias returns.
*/
if ((trg = frame_pointer->ret_value) && !alias_return) /* CAUTION: Assignment */
{ /* If this is an alias_return arg, bypass the arg set logic which was done above. */
assert(!got_ret_target);
got_ret_target = TRUE;
*trg = ret_value;
}
/* do not throw an error if return value is expected from a non-extrinsic, but dollar_zquit_anyway is true */
if (!dollar_zquit_anyway && !got_ret_target)
rts_error(VARLSTCNT(1) ERR_NOTEXTRINSIC); /* This routine was not invoked as an extrinsic function */
/* Note that error_ret() should be invoked only after the rts_error() of TPQUIT and NOTEXTRINSIC.
* This is so the TPQUIT/NOTEXTRINSIC error gets noted down in $ECODE (which wont happen if error_ret() is called before).
*/
INVOKE_ERROR_RET_IF_NEEDED;
if (is_tracing_on)
(*unw_prof_frame_ptr)();
msp = (unsigned char *)frame_pointer + SIZEOF(stack_frame);
DRAIN_GLVN_POOL_IF_NEEDED;
PARM_ACT_UNSTACK_IF_NEEDED;
frame_pointer = frame_pointer->old_frame_pointer;
DBGEHND((stderr, "unw_retarg: Stack frame 0x"lvaddr" unwound - frame 0x"lvaddr" now current - New msp: 0x"lvaddr"\n",
prevfp, frame_pointer, msp));
if ((NULL != zyerr_frame) && (frame_pointer > zyerr_frame))
zyerr_frame = NULL;
if (!frame_pointer)
rts_error(VARLSTCNT(1) ERR_STACKUNDERFLO);
assert(frame_pointer >= (stack_frame *)msp);
/* ensuring that trg is not NULL */
if (!dollar_zquit_anyway || trg)
trg->mvtype |= MV_RETARG;
assert((frame_pointer < frame_pointer->old_frame_pointer) || (NULL == frame_pointer->old_frame_pointer));
return 0;
}
void op_fnorder(lv_val *src, mval *key, mval *dst)
{
mval tmp_sbs;
int length;
boolean_t is_canonical, is_fnnext, get_first;
lvTree *lvt;
lvTreeNode *node;
uint4 mvt; /* Local copy of mvtype, bit ands use a int4, so do conversion once */
mstr *str;
int4 intval;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
is_fnnext = TREF(in_op_fnnext);
TREF(in_op_fnnext) = FALSE;
if (src && (lvt = LV_GET_CHILD(src))) /* caution: assignment */
{
MV_FORCE_DEFINED(key);
/* If last subscript is null, $ORDER returns the first subscript in that level.
* With the obsoleted $NEXT function, a subscript of -1 also triggers the same behavior.
*/
get_first = FALSE;
if (MV_IS_STRING(key) && (0 == key->str.len))
get_first = TRUE;
else if (is_fnnext)
{
mvt = key->mvtype;
if (!(mvt & (MV_NM | MV_NUM_APPROX)))
{ /* Not currently in numeric form. Is it cannonical? */
if (val_iscan(key))
{ /* Yes, convert it to numeric */
(void)s2n(key);
mvt = key->mvtype;
if (!(mvt & MV_NM))
rts_error(VARLSTCNT(1) ERR_NUMOFLOW);
} else /* No, not numeric. Note the fact for future reference */
mvt = key->mvtype |= MV_NUM_APPROX;
}
if (MV_IS_TRUEINT(key, &intval) && (MINUS_ONE == key->m[1]))
get_first = TRUE;
}
if (get_first)
node = lvAvlTreeFirst(lvt);
else
{
is_canonical = MV_IS_CANONICAL(key);
if (!is_canonical)
{
assert(!TREE_KEY_SUBSCR_IS_CANONICAL(key->mvtype));
if (TREF(local_collseq))
{
ALLOC_XFORM_BUFF(key->str.len);
tmp_sbs.mvtype = MV_STR;
tmp_sbs.str.len = TREF(max_lcl_coll_xform_bufsiz);
assert(NULL != TREF(lcl_coll_xform_buff));
tmp_sbs.str.addr = TREF(lcl_coll_xform_buff);
do_xform(TREF(local_collseq), XFORM, &key->str, &tmp_sbs.str, &length);
tmp_sbs.str.len = length;
s2pool(&(tmp_sbs.str));
key = &tmp_sbs;
}
} else
{ /* Need to set canonical bit before calling tree search functions.
* But input mval could be read-only so cannot modify that even if temporarily.
* So take a copy of the mval and modify that instead.
*/
tmp_sbs = *key;
key = &tmp_sbs;
MV_FORCE_NUM(key);
TREE_KEY_SUBSCR_SET_MV_CANONICAL_BIT(key); /* used by the lvTreeKeyNext function */
}
node = lvAvlTreeKeyNext(lvt, key);
}
/* If STDNULLCOLL, skip to the next subscript should the current subscript be "" */
if (TREF(local_collseq_stdnull) && (NULL != node) && LV_NODE_KEY_IS_NULL_SUBS(node))
{
assert(LVNULLSUBS_OK == TREF(lv_null_subs));
node = lvAvlTreeNext(node);
}
} else
node = NULL;
if (NULL == node)
{
if (!is_fnnext)
{
dst->mvtype = MV_STR;
dst->str.len = 0;
} else
MV_FORCE_MVAL(dst, -1);
} else
{
LV_NODE_GET_KEY(node, dst); /* Get node key into "dst" depending on the structure type of "node" */
/* Code outside lv_tree.c does not currently know to make use of MV_CANONICAL bit so reset it
* until the entire codebase gets fixed to maintain MV_CANONICAL bit accurately at which point,
* this RESET can be removed */
TREE_KEY_SUBSCR_RESET_MV_CANONICAL_BIT(dst);
if (TREF(local_collseq) && MV_IS_STRING(dst))
{
ALLOC_XFORM_BUFF(dst->str.len);
assert(NULL != TREF(lcl_coll_xform_buff));
tmp_sbs.str.addr = TREF(lcl_coll_xform_buff);
tmp_sbs.str.len = TREF(max_lcl_coll_xform_bufsiz);
do_xform(TREF(local_collseq), XBACK, &dst->str, &tmp_sbs.str, &length);
tmp_sbs.str.len = length;
s2pool(&(tmp_sbs.str));
dst->str = tmp_sbs.str;
}
}
}
void op_svput(int varnum, mval *v)
{
int i, ok, state;
char *vptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
switch (varnum)
{
case SV_X:
MV_FORCE_NUM(v);
io_curr_device.out->dollar.x = (short)MV_FORCE_INT(v);
if ((short)(io_curr_device.out->dollar.x) < 0)
io_curr_device.out->dollar.x = 0;
break;
case SV_Y:
MV_FORCE_NUM(v);
io_curr_device.out->dollar.y = (short)MV_FORCE_INT(v);
if ((short)(io_curr_device.out->dollar.y) < 0)
io_curr_device.out->dollar.y = 0;
break;
case SV_ZCOMPILE:
MV_FORCE_STR(v);
if ((TREF(dollar_zcompile)).addr)
free ((TREF(dollar_zcompile)).addr);
(TREF(dollar_zcompile)).addr = (char *)malloc(v->str.len);
memcpy((TREF(dollar_zcompile)).addr, v->str.addr, v->str.len);
(TREF(dollar_zcompile)).len = v->str.len;
break;
case SV_ZSTEP:
MV_FORCE_STR(v);
op_commarg(v,indir_linetail);
op_unwind();
dollar_zstep = *v;
break;
case SV_ZGBLDIR:
MV_FORCE_STR(v);
if ((dollar_zgbldir.str.len != v->str.len)
|| memcmp(dollar_zgbldir.str.addr, v->str.addr, dollar_zgbldir.str.len))
{
if (0 == v->str.len)
{
/* set $zgbldir="" */
dpzgbini();
gd_header = NULL;
} else
{
gd_header = zgbldir(v);
/* update the gd_map */
SET_GD_MAP;
dollar_zgbldir.str.len = v->str.len;
dollar_zgbldir.str.addr = v->str.addr;
s2pool(&dollar_zgbldir.str);
}
if (NULL != gv_currkey)
{
gv_currkey->base[0] = '\0';
gv_currkey->prev = gv_currkey->end = 0;
} else if (NULL != gd_header)
gvinit();
if (NULL != gv_target)
gv_target->clue.end = 0;
}
break;
case SV_ZMAXTPTIME:
dollar_zmaxtptime = mval2i(v);
break;
case SV_ZROUTINES:
MV_FORCE_STR(v);
/* The string(v) should be parsed and loaded before setting $zroutines
* to retain the old value in case errors occur while loading */
zro_load(&v->str);
if ((TREF(dollar_zroutines)).addr)
free ((TREF(dollar_zroutines)).addr);
(TREF(dollar_zroutines)).addr = (char *)malloc(v->str.len);
memcpy((TREF(dollar_zroutines)).addr, v->str.addr, v->str.len);
(TREF(dollar_zroutines)).len = v->str.len;
break;
case SV_ZSOURCE:
MV_FORCE_STR(v);
dollar_zsource.mvtype = MV_STR;
dollar_zsource.str = v->str;
break;
case SV_ZTRAP:
# ifdef GTM_TRIGGER
if (0 < gtm_trigger_depth)
rts_error(VARLSTCNT(1) ERR_NOZTRAPINTRIG);
# endif
MV_FORCE_STR(v);
if (ztrap_new)
op_newintrinsic(SV_ZTRAP);
dollar_ztrap.mvtype = MV_STR;
dollar_ztrap.str = v->str;
/* Setting either $ZTRAP or $ETRAP to empty causes any current error trapping to be canceled */
if (!v->str.len)
{
dollar_etrap.mvtype = MV_STR;
dollar_etrap.str = v->str;
ztrap_explicit_null = TRUE;
} else /* Ensure that $ETRAP and $ZTRAP are not both active at the same time */
{
ztrap_explicit_null = FALSE;
if (dollar_etrap.str.len > 0)
gtm_newintrinsic(&dollar_etrap);
}
if (ztrap_form & ZTRAP_POP)
ztrap_save_ctxt();
if (tp_timeout_deferred && !dollar_zininterrupt)
/* A tp timeout was deferred. Now that $ETRAP is no longer in effect and no job interrupt is in
* effect, the timeout need no longer be deferred and can be recognized.
*/
tptimeout_set(0);
break;
case SV_ZSTATUS:
MV_FORCE_STR(v);
dollar_zstatus.mvtype = MV_STR;
dollar_zstatus.str = v->str;
break;
case SV_PROMPT:
MV_FORCE_STR(v);
MV_FORCE_LEN_STRICT(v); /* Ensure that direct mode prompt will not have BADCHARs,
* otherwise the BADCHAR error may fill up the filesystem
*/
if (v->str.len <= SIZEOF_prombuf)
(TREF(gtmprompt)).len = v->str.len;
else if (!gtm_utf8_mode)
(TREF(gtmprompt)).len = SIZEOF_prombuf;
# ifdef UNICODE_SUPPORTED
else
{
UTF8_LEADING_BYTE(v->str.addr + SIZEOF_prombuf, v->str.addr, vptr);
(TREF(gtmprompt)).len = INTCAST(vptr - v->str.addr);
}
# endif
memcpy((TREF(gtmprompt)).addr, v->str.addr, (TREF(gtmprompt)).len);
break;
case SV_ECODE:
MV_FORCE_STR(v);
if (v->str.len)
{
/* Format must be like ,Mnnn,Mnnn,Zxxx,Uxxx,
* Mnnn are ANSI standard error codes
* Zxxx are implementation-specific codes
* Uxxx are end-user defined codes
* Note that there must be commas at the start and at the end
*/
for (state = 2, i = 0; (i < v->str.len) && (state <= 2); i++)
{
switch(state)
{
case 2: state = (v->str.addr[i] == ',') ? 1 : 101;
break;
case 1: state = ((v->str.addr[i] == 'M') ||
(v->str.addr[i] == 'U') ||
(v->str.addr[i] == 'Z')) ? 0 : 101;
break;
case 0: state = (v->str.addr[i] == ',') ? 1 : 0;
break;
}
}
/* The above check would pass strings like ","
* so double-check that there are at least three characters
* (starting comma, ending comma, and something in between)
*/
if ((state != 1) || (v->str.len < 3))
{
/* error, ecode = M101 */
rts_error(VARLSTCNT(4) ERR_INVECODEVAL, 2, v->str.len, v->str.addr);
}
}
if (v->str.len > 0)
{
ecode_add(&v->str);
rts_error(VARLSTCNT(2) ERR_SETECODE, 0);
} else
{
NULLIFY_DOLLAR_ECODE; /* reset $ECODE related variables to correspond to $ECODE = NULL state */
NULLIFY_ERROR_FRAME; /* we are no more in error-handling mode */
if (tp_timeout_deferred && !dollar_zininterrupt)
/* A tp timeout was deferred. Now that we are clear of error handling and no job interrupt
* is in process, allow the timeout to be recognized.
*/
tptimeout_set(0);
}
break;
case SV_ETRAP:
MV_FORCE_STR(v);
dollar_etrap.mvtype = MV_STR;
dollar_etrap.str = v->str;
/* Setting either $ZTRAP or $ETRAP to empty causes any current error trapping to be canceled */
if (!v->str.len)
{
dollar_ztrap.mvtype = MV_STR;
dollar_ztrap.str = v->str;
} else if (dollar_ztrap.str.len > 0)
{ /* Ensure that $ETRAP and $ZTRAP are not both active at the same time */
assert(FALSE == ztrap_explicit_null);
gtm_newintrinsic(&dollar_ztrap);
}
ztrap_explicit_null = FALSE;
break;
case SV_ZERROR:
MV_FORCE_STR(v);
dollar_zerror.mvtype = MV_STR;
dollar_zerror.str = v->str;
break;
case SV_ZYERROR:
MV_FORCE_STR(v);
dollar_zyerror.mvtype = MV_STR;
dollar_zyerror.str = v->str;
break;
case SV_SYSTEM:
assert(FALSE);
rts_error(VARLSTCNT(4) ERR_SYSTEMVALUE, 2, v->str.len, v->str.addr);
break;
case SV_ZDIR:
setzdir(v, NULL); /* change directory to v */
getzdir(); /* update dollar_zdir with current working directory */
break;
case SV_ZINTERRUPT:
MV_FORCE_STR(v);
dollar_zinterrupt.mvtype = MV_STR;
dollar_zinterrupt.str = v->str;
break;
case SV_ZDATE_FORM:
MV_FORCE_NUM(v);
TREF(zdate_form) = (short)MV_FORCE_INT(v);
break;
case SV_ZTEXIT:
MV_FORCE_STR(v);
dollar_ztexit.mvtype = MV_STR;
dollar_ztexit.str = v->str;
/* Coercing $ZTEXIT to boolean at SET command is more efficient than coercing before each
* rethrow at TR/TRO. Since we want to maintain dollar_ztexit as a string, coercion should
* not be performed on dollar_ztext, but on a temporary (i.e. parameter v)
*/
dollar_ztexit_bool = MV_FORCE_BOOL(v);
break;
case SV_ZQUIT:
dollar_zquit_anyway = MV_FORCE_BOOL(v);
break;
case SV_ZTVALUE:
# ifdef GTM_TRIGGER
assert(!dollar_tlevel || (tstart_trigger_depth <= gtm_trigger_depth));
if (!dollar_tlevel || (tstart_trigger_depth == gtm_trigger_depth))
rts_error(VARLSTCNT(4) ERR_SETINTRIGONLY, 2, RTS_ERROR_TEXT("$ZTVALUE"));
if (dollar_ztriggerop != &gvtr_cmd_mval[GVTR_CMDTYPE_SET])
rts_error(VARLSTCNT(4) ERR_SETINSETTRIGONLY, 2, RTS_ERROR_TEXT("$ZTVALUE"));
assert(0 < gtm_trigger_depth);
memcpy(dollar_ztvalue, v, SIZEOF(mval));
dollar_ztvalue->mvtype &= ~MV_ALIASCONT; /* Make sure to shut off alias container flag on copy */
assert(NULL != ztvalue_changed_ptr);
*ztvalue_changed_ptr = TRUE;
break;
# else
rts_error(VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTWORMHOLE:
# ifdef GTM_TRIGGER
MV_FORCE_STR(v);
/* See jnl.h for why MAX_ZTWORMHOLE_SIZE should be less than minimum alignsize */
assert(MAX_ZTWORMHOLE_SIZE < (JNL_MIN_ALIGNSIZE * DISK_BLOCK_SIZE));
if (MAX_ZTWORMHOLE_SIZE < v->str.len)
rts_error(VARLSTCNT(4) ERR_ZTWORMHOLE2BIG, 2, v->str.len, MAX_ZTWORMHOLE_SIZE);
dollar_ztwormhole.mvtype = MV_STR;
dollar_ztwormhole.str = v->str;
break;
# else
rts_error(VARLSTCNT(1) ERR_UNIMPLOP);
# endif
case SV_ZTSLATE:
# ifdef GTM_TRIGGER
assert(!dollar_tlevel || (tstart_trigger_depth <= gtm_trigger_depth));
if (!dollar_tlevel || (tstart_trigger_depth == gtm_trigger_depth))
rts_error(VARLSTCNT(4) ERR_SETINTRIGONLY, 2, RTS_ERROR_TEXT("$ZTSLATE"));
assert(0 < gtm_trigger_depth);
MV_FORCE_DEFINED(v);
memcpy((char *)&dollar_ztslate, v, SIZEOF(mval));
dollar_ztslate.mvtype &= ~MV_ALIASCONT; /* Make sure to shut off alias container flag on copy */
break;
# else
rts_error(VARLSTCNT(1) ERR_UNIMPLOP);
# endif
default:
GTMASSERT;
}
return;
}
void op_fnzprevious(lv_val *src, mval *key, mval *dst)
{
int cur_subscr, length;
mval tmp_sbs;
lvTreeNode *node;
lvTree *lvt;
boolean_t is_canonical, get_last;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (src && (lvt = LV_GET_CHILD(src))) /* caution: assignment */
{
MV_FORCE_DEFINED(key);
/* If last subscript is null, $zprev returns the last subscript in that level. */
get_last = FALSE;
if (MV_IS_STRING(key) && (0 == key->str.len))
get_last = TRUE;
if (get_last)
node = lvAvlTreeLast(lvt);
else
{
is_canonical = MV_IS_CANONICAL(key);
if (!is_canonical)
{
assert(!TREE_KEY_SUBSCR_IS_CANONICAL(key->mvtype));
if (TREF(local_collseq))
{
ALLOC_XFORM_BUFF(key->str.len);
tmp_sbs.mvtype = MV_STR;
tmp_sbs.str.len = TREF(max_lcl_coll_xform_bufsiz);
assert(NULL != TREF(lcl_coll_xform_buff));
tmp_sbs.str.addr = TREF(lcl_coll_xform_buff);
do_xform(TREF(local_collseq), XFORM, &key->str, &tmp_sbs.str, &length);
tmp_sbs.str.len = length;
s2pool(&(tmp_sbs.str));
key = &tmp_sbs;
}
} else
{ /* Need to set canonical bit before calling tree search functions.
* But input mval could be read-only so cannot modify that even if temporarily.
* So take a copy of the mval and modify that instead.
*/
tmp_sbs = *key;
key = &tmp_sbs;
MV_FORCE_NUM(key);
TREE_KEY_SUBSCR_SET_MV_CANONICAL_BIT(key); /* used by the lvAvlTreeKeyPrev function */
}
node = lvAvlTreeKeyPrev(lvt, key);
}
/* If STDNULLCOLL, skip to the previous subscript should the current subscript be "" */
if (TREF(local_collseq_stdnull) && (NULL != node) && LV_NODE_KEY_IS_NULL_SUBS(node))
{
assert(LVNULLSUBS_OK == TREF(lv_null_subs));
node = lvAvlTreePrev(node);
}
} else
node = NULL;
if (NULL == node)
{
dst->mvtype = MV_STR;
dst->str.len = 0;
} else
{
LV_NODE_GET_KEY(node, dst); /* Get node key into "dst" depending on the structure type of "node" */
/* Code outside lv_tree.c does not currently know to make use of MV_CANONICAL bit so reset it
* until the entire codebase gets fixed to maintain MV_CANONICAL bit accurately at which point,
* this RESET can be removed */
TREE_KEY_SUBSCR_RESET_MV_CANONICAL_BIT(dst);
if (TREF(local_collseq) && MV_IS_STRING(dst))
{
ALLOC_XFORM_BUFF(dst->str.len);
assert(NULL != TREF(lcl_coll_xform_buff));
tmp_sbs.str.addr = TREF(lcl_coll_xform_buff);
tmp_sbs.str.len = TREF(max_lcl_coll_xform_bufsiz);
do_xform(TREF(local_collseq), XBACK, &dst->str, &tmp_sbs.str, &length);
tmp_sbs.str.len = length;
s2pool(&(tmp_sbs.str));
dst->str = tmp_sbs.str;
}
}
return;
}
/*
* ---------------------------------------------------
* Job command main entry point
* ---------------------------------------------------
*/
int op_job(int4 argcnt, ...)
{
va_list var;
int4 i;
mval *label, *inp;
int4 offset;
mval *routine, *param_buf;
int4 timeout; /* timeout in seconds */
int4 msec_timeout; /* timeout in milliseconds */
boolean_t timed, single_attempt, non_exit_return;
unsigned char buff[128], *c;
int4 status, exit_stat, term_sig, stop_sig;
pid_t zjob_pid = 0; /* zjob_pid should exactly match in type with child_pid(ojstartchild.c) */
int pipe_fds[2], pipe_status;
# ifdef _BSD
union wait wait_stat;
# else
int4 wait_stat;
# endif
job_params_type job_params;
char combuf[128];
mstr command;
job_parm *jp;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
VAR_START(var, argcnt);
assert(argcnt >= 5);
label = va_arg(var, mval *);
offset = va_arg(var, int4);
routine = va_arg(var, mval *);
param_buf = va_arg(var, mval *);
timeout = va_arg(var, int4); /* in seconds */
argcnt -= 5;
/* initialize $zjob = 0, in case JOB fails */
dollar_zjob = 0;
MV_FORCE_DEFINED(label);
MV_FORCE_DEFINED(routine);
MV_FORCE_DEFINED(param_buf);
/* create a pipe to channel the PID of the jobbed off process(J) from middle level
* process(M) to the current process (P)
*/
OPEN_PIPE(pipe_fds, pipe_status);
if (-1 == pipe_status)
{
va_end(var);
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(7) ERR_JOBFAIL, 0, ERR_TEXT, 2, LEN_AND_LIT("Error creating pipe"), errno);
}
jobcnt++;
command.addr = &combuf[0];
/* Setup job parameters by parsing param_buf and using label, offset, routine, & timeout). */
job_params.routine = routine->str;
job_params.label = label->str;
job_params.offset = offset;
ojparams(param_buf->str.addr, &job_params);
/*
* Verify that entryref to JOB command is not NULL.
*/
if (!job_params.routine.len)
{
va_end(var);
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(4) ERR_JOBFAIL, 0, ERR_NULLENTRYREF, 0);
}
/* Clear the buffers */
flush_pio();
/* Start the timer */
ojtimeout = FALSE;
if (timeout < 0)
timeout = 0;
else if (TREF(tpnotacidtime) < timeout)
TPNOTACID_CHECK(JOBTIMESTR);
if (NO_M_TIMEOUT == timeout)
{
timed = FALSE;
msec_timeout = NO_M_TIMEOUT;
} else
{
timed = TRUE;
msec_timeout = timeout2msec(timeout);
if (msec_timeout > 0)
start_timer((TID)&tid, msec_timeout, job_timer_handler, 0, NULL);
}
if (argcnt)
{
jp = job_params.parms = (job_parm *)malloc(SIZEOF(job_parm) * argcnt);
i = argcnt;
for(;;)
{
inp = va_arg(var, mval *);
jp->parm = inp;
if (0 == --i)
break;
jp->next = jp + 1;
jp = jp->next;
}
jp->next = 0;
} else
void op_indget(mval *dst, mval *target, mval *value)
{
icode_str indir_src;
int rval;
ht_ent_mname *tabent;
mstr *obj, object;
oprtype v;
triple *s, *src, *oldchain, tmpchain, *r, *triptr;
var_tabent targ_key;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if ((TREF(ind_source_sp) >= TREF(ind_source_top)) || (TREF(ind_result_sp) >= TREF(ind_result_top)))
rts_error(VARLSTCNT(1) ERR_INDMAXNEST); /* mdbcondition_handler resets ind_result_sp & ind_source_sp */
MV_FORCE_DEFINED(value);
MV_FORCE_STR(target);
indir_src.str = target->str;
indir_src.code = indir_get;
if (NULL == (obj = cache_get(&indir_src)))
{
obj = &object;
if (valid_mname(&target->str))
{
targ_key.var_name = target->str;
COMPUTE_HASH_MNAME(&targ_key);
tabent = lookup_hashtab_mname(&curr_symval->h_symtab, &targ_key);
if (!tabent || !LV_IS_VAL_DEFINED(tabent->value))
*dst = *value;
else
*dst = ((lv_val *)tabent->value)->v;
dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
return;
}
comp_init(&target->str);
src = newtriple(OC_IGETSRC);
switch (TREF(window_token))
{
case TK_IDENT:
if (EXPR_FAIL != (rval = lvn(&v, OC_SRCHINDX, 0))) /* NOTE assignment */
{
s = newtriple(OC_FNGET2);
s->operand[0] = v;
s->operand[1] = put_tref(src);
}
break;
case TK_CIRCUMFLEX:
if (EXPR_FAIL != (rval = gvn())) /* NOTE assignment */
{
r = newtriple(OC_FNGVGET1);
s = newtriple(OC_FNGVGET2);
s->operand[0] = put_tref(r);
s->operand[1] = put_tref(src);
}
break;
case TK_ATSIGN:
TREF(saw_side_effect) = TREF(shift_side_effects);
if (TREF(shift_side_effects) && (GTM_BOOL == TREF(gtm_fullbool)))
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (EXPR_FAIL != (rval = indirection(&v))) /* NOTE assignment */
{
s = newtriple(OC_INDGET);
s->operand[0] = v;
s->operand[1] = put_tref(src);
newtriple(OC_GVSAVTARG);
setcurtchain(oldchain);
dqadd(TREF(expr_start), &tmpchain, exorder);
TREF(expr_start) = tmpchain.exorder.bl;
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(TREF(expr_start));
} else
setcurtchain(oldchain);
} else
{
if (EXPR_FAIL != (rval = indirection(&v))) /* NOTE assignment */
{
s = newtriple(OC_INDGET);
s->operand[0] = v;
s->operand[1] = put_tref(src);
}
}
break;
default:
stx_error(ERR_VAREXPECTED);
rval = EXPR_FAIL;
break;
}
v = put_tref(s);
if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &v, target->str.len))
return;
indir_src.str.addr = target->str.addr;
cache_put(&indir_src, obj);
/* Fall into code activation below */
}
*(TREF(ind_result_sp))++ = dst;
*(TREF(ind_source_sp))++ = value;
comp_indr(obj);
return;
}
void op_fnorder(lv_val *src, mval *key, mval *dst)
{
int cur_subscr;
mval tmp_sbs;
int length;
sbs_blk *num, *str;
boolean_t found, is_neg;
int4 i;
lv_val **lv;
lv_sbs_tbl *tbl;
sbs_search_status status;
boolean_t is_fnnext;
is_fnnext = in_op_fnnext;
in_op_fnnext = FALSE;
found = FALSE;
if (src)
{
if (tbl = src->ptrs.val_ent.children)
{
MV_FORCE_DEFINED(key);
num = tbl->num;
str = tbl->str;
assert(tbl->ident == MV_SBS);
if ((MV_IS_STRING(key) && key->str.len == 0) || (is_fnnext && MV_IS_INT(key) && key->m[1] == MINUS_ONE))
{ /* With GT.M collation , if last subscript is null, $o returns the first subscript in that level */
if (tbl->int_flag)
{
assert(num);
for (i = 0, lv = &num->ptr.lv[0]; i < SBS_NUM_INT_ELE; i++, lv++)
{
if (*lv)
{
MV_FORCE_MVAL(dst,i);
found = TRUE;
break;
}
}
} else if (num)
{
assert(num->cnt);
MV_ASGN_FLT2MVAL((*dst),num->ptr.sbs_flt[0].flt);
found = TRUE;
}
} else
{
if (MV_IS_CANONICAL(key))
{
MV_FORCE_NUM(key);
if (tbl->int_flag)
{
assert(num);
is_neg = (key->mvtype & MV_INT) ? key->m[1] < 0 : key->sgn;
if (is_neg)
i = 0;
else
{
if (!is_fnnext && (1 == numcmp(key, (mval *)&SBS_MVAL_INT_ELE)))
i = SBS_NUM_INT_ELE;
else
{
i = MV_FORCE_INT(key);
i++;
}
}
for (lv = &num->ptr.lv[i]; i < SBS_NUM_INT_ELE; i++, lv++)
{
if (*lv)
{
MV_FORCE_MVAL(dst,i);
found = TRUE;
break;
}
}
} else if (num && lv_nxt_num_inx(num, key, &status))
{
MV_ASGN_FLT2MVAL((*dst),((sbs_flt_struct*)status.ptr)->flt);
found = TRUE;
}
} else
{
if (local_collseq)
{
ALLOC_XFORM_BUFF(&key->str);
tmp_sbs.mvtype = MV_STR;
tmp_sbs.str.len = max_lcl_coll_xform_bufsiz;
assert(NULL != lcl_coll_xform_buff);
tmp_sbs.str.addr = lcl_coll_xform_buff;
do_xform(local_collseq, XFORM, &key->str,
&tmp_sbs.str, &length);
tmp_sbs.str.len = length;
s2pool(&(tmp_sbs.str));
key = &tmp_sbs;
}
if (str && lv_nxt_str_inx(str, &key->str, &status))
{
dst->mvtype = MV_STR;
dst->str = ((sbs_str_struct *)status.ptr)->str;
} else
{
if (!is_fnnext)
{
dst->mvtype = MV_STR;
dst->str.len = 0;
} else
MV_FORCE_MVAL(dst, -1);
}
found = TRUE;
}
}
if (!found && str)
{ /* We are here because
* a. key is "" and there is no numeric subscript, OR
* b. key is numeric and it is >= the largest numeric subscript at this level implying a switch from
* numeric to string subscripts
* Either case, return the first string subscript. However, for STDNULLCOLL, skip to the next
* subscript should the first subscript be ""
*/
assert(str->cnt);
dst->mvtype = MV_STR;
dst->str = str->ptr.sbs_str[0].str;
found = TRUE;
if (local_collseq_stdnull && 0 == dst->str.len)
{
assert(lv_null_subs);
if (lv_nxt_str_inx(str, &dst->str, &status))
{
dst->str = ((sbs_str_struct*)status.ptr)->str;
} else
found = FALSE;
}
}
}
}
if (!found)
{
if (!is_fnnext)
{
dst->mvtype = MV_STR;
dst->str.len = 0;
} else
MV_FORCE_MVAL(dst, -1);
} else if (dst->mvtype == MV_STR && local_collseq)
{
ALLOC_XFORM_BUFF(&dst->str);
assert(NULL != lcl_coll_xform_buff);
tmp_sbs.str.addr = lcl_coll_xform_buff;
tmp_sbs.str.len = max_lcl_coll_xform_bufsiz;
do_xform(local_collseq, XBACK,
&dst->str, &tmp_sbs.str, &length);
tmp_sbs.str.len = length;
s2pool(&(tmp_sbs.str));
dst->str = tmp_sbs.str;
}
}
