double mval2double(mval *v)
{
double x, y;
int exp;
MV_FORCE_NUM(v);
x = v->m[1];
if (v->mvtype & MV_INT)
x /= MV_BIAS;
else
{
exp = v->e;
y = v->m[0];
y = y / MANT_HI;
while (exp > EXP_IDX_BIAL)
{
x *= MANT_HI;
y *= MANT_HI;
exp -= 9;
}
while (exp < MV_XBIAS)
{
x /= MANT_HI;
y /= MANT_HI;
exp += 9;
}
x /= ten_pwr[EXP_IDX_BIAL - exp];
y /= ten_pwr[EXP_IDX_BIAL - exp];
x += y;
x = (v->sgn ? -x : x);
}
return x;
}
/*
* ------------------------------------------
* 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)
gtm_int64_t mval2i8(mval *v)
{
gtm_int64_t x, y;
int exp;
MV_FORCE_NUM(v);
if (v->mvtype & MV_INT)
x = v->m[1] / MV_BIAS;
else
{
exp = v->e;
if (exp > EXP_IDX_BIAL)
{ /* Case where to get the actual value we need to multiply by power of exponent. */
x = v->m[1];
y = v->m[0];
if (y > 0)
{ /* Both m[0] and m[1] are used, so multiply in parallel, but first ensure that the m[1] part has
* a decimal exponent of MANT_HI order.
*/
x *= MANT_HI;
while (exp > EXP_IDX_BIAL + 18)
{ /* Keep multiplying by 10^9, but keep a precision "buffer" of 18 to prevent further
* divisions, as we might otherwise compromise the available precision of mval.
*/
x *= MANT_HI;
y *= MANT_HI;
exp -= 9;
}
if (exp >= EXP_IDX_BIAL + 9)
{ /* Multiply by the remaining power of the exponent. */
x *= ten_pwr[exp - EXP_IDX_BIAL - 9];
y *= ten_pwr[exp - EXP_IDX_BIAL - 9];
} else
{ /* Case where exponent indicates a total power of less than 10^9, which, given that both
* m[0] and m[1] are used and that x has already been multiplied by 10^9, requires a
* division to make the sum of m[0] and m[1] represent the right number.
*/
x /= ten_pwr[EXP_IDX_BIAL + 9 - exp];
y /= ten_pwr[EXP_IDX_BIAL + 9 - exp];
}
} else
{ /* Since m[0] is not used, just multiply x by the excess power of the exponent. */
while (exp > EXP_IDX_BIAL + 9)
{
x *= MANT_HI;
exp -= 9;
}
x *= ten_pwr[exp - EXP_IDX_BIAL];
}
x = (v->sgn ? -x - y : x + y);
} else if (exp < MV_XBIAS)
x = 0;
else
x = (v->sgn ? -v->m[1] : v->m[1]) / ten_pwr[EXP_IDX_BIAL - exp];
}
return x;
}
/* Routine to return a string in zwrite format */
void op_fnzwrite(mval* src, mval* dst)
{
int dst_len, str_len;
MV_FORCE_STR(src);
MV_FORCE_NUM(src);
if MV_IS_CANONICAL(src)
*dst = *src;
else
{
void op_indo2(mval *dst, uint4 indx, mval *direct)
{
glvn_pool_entry *slot;
int4 dummy_intval;
intszofptr_t n;
lv_val *lv;
mval *key;
opctype oc;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
MV_FORCE_NUM(direct);
if (!MV_IS_TRUEINT(direct, &dummy_intval) || (direct->m[1] != (1 * MV_BIAS) && direct->m[1] != (-1 * MV_BIAS)))
rts_error(VARLSTCNT(1) ERR_ORDER2);
slot = &((TREF(glvn_pool_ptr))->slot[indx]);
oc = slot->sav_opcode;
if (OC_SAVLVN == oc)
{ /* lvn */
n = --slot->glvn_info.n;
if (0 == n)
{ /* lvn name */
slot->glvn_info.n++; /* quick restore count so glvnpop works correctly */
/* like op_fnlvnameo2 */
if ((1 * MV_BIAS) == direct->m[1])
op_fnlvname(slot->lvname, FALSE, dst);
else
op_fnlvprvname(slot->lvname, dst);
} else
{ /* subscripted lv */
key = (mval *)slot->glvn_info.arg[n];
lv = op_rfrshlvn(indx, OC_RFRSHLVN); /* funky opcode prevents UNDEF in rfrlvn */
slot->glvn_info.n++; /* quick restore count so glvnpop works correctly */
/* like op_fnno2 */
if ((1 * MV_BIAS) == direct->m[1])
op_fnorder(lv, key, dst);
else
op_fnzprevious(lv, key, dst);
}
} else if (OC_NOOP != oc) /* if indirect error blew set up, skip this */
{ /* gvn */
op_rfrshgvn(indx, oc);
/* like op_gvno2 */
if ((1 * MV_BIAS) == direct->m[1])
op_gvorder(dst);
else
op_zprevious(dst);
}
return;
}
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);
}
}
void op_gvincr(mval *increment, mval *result)
{
unsigned char buff[MAX_ZWR_KEY_SZ], *end;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
/* If specified var name is global ^%Y*, the name is illegal to use in a SET or KILL command, only GETs are allowed */
if ((RESERVED_NAMESPACE_LEN <= gv_currkey->end) && (0 == MEMCMP_LIT(gv_currkey->base, RESERVED_NAMESPACE)))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(1) ERR_PCTYRESERVED);
if (gv_cur_region->read_only)
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(4) ERR_DBPRIVERR, 2, DB_LEN_STR(gv_cur_region));
if ((TREF(gv_last_subsc_null) || TREF(gv_some_subsc_null)) && (ALWAYS != gv_cur_region->null_subs))
sgnl_gvnulsubsc();
assert(gv_currkey->end + 1 <= gv_cur_region->max_key_size);
MV_FORCE_NUM(increment);
switch (gv_cur_region->dyn.addr->acc_meth)
{
case dba_bg:
case dba_mm:
gvcst_incr(increment, result);
break;
case dba_cm:
gvcmx_increment(increment, result);
break;
case dba_usr:
/* $INCR not supported for DDP/USR access method */
if (0 == (end = format_targ_key(buff, MAX_ZWR_KEY_SZ, gv_currkey, TRUE)))
end = &buff[MAX_ZWR_KEY_SZ - 1];
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(10) ERR_UNIMPLOP, 0,
ERR_TEXT, 2, LEN_AND_LIT("GTCM DDP server does not support $INCREMENT"),
ERR_GVIS, 2, end - buff, buff,
ERR_TEXT, 2, REG_LEN_STR(gv_cur_region));
break;
default:
assertpro(FALSE);
}
assert(MV_DEFINED(result));
}
/* Converts an mval into a 32-bit unsigned integer, or MAXUINT4 on overflow. */
uint4 mval2ui(mval *v)
{
uint4 i;
double j;
int exp;
MV_FORCE_NUM(v);
if (v->mvtype & MV_INT)
i = v->m[1] / MV_BIAS;
else
{
exp = v->e;
if (exp > EXP_IDX_BIAL)
{
j = mval2double(v);
i = (MAXUINT4 >= j) ? (uint4)j : MAXUINT4;
} else if (exp < MV_XBIAS)
i = 0;
else
i = (v->sgn ? -v->m[1] : v->m[1]) / ten_pwr[EXP_IDX_BIAL - exp];
}
return i;
}
void op_fnfnumber(mval *src, mval *fmt, mval *dst)
{
mval temp, *temp_p;
unsigned char fncode, sign, *ch, *cp, *ff, *ff_top, *t;
int ct, x, y, z, xx;
boolean_t comma, paren;
error_def(ERR_FNARGINC);
error_def(ERR_FNUMARG);
assert (stringpool.free >= stringpool.base);
assert (stringpool.free <= stringpool.top);
/* assure that there is adequate space for two string forms of a number
as a local version of the src must be operated upon in order to get
a canonical number
*/
ENSURE_STP_FREE_SPACE(MAX_NUM_SIZE * 2);
/* operate on the src operand in a temp, so that
conversions are possible without destroying the source
*/
temp_p = &temp;
*temp_p = *src;
/* if the source operand is not a canonical number, force conversion
*/
MV_FORCE_STR(temp_p);
MV_FORCE_STR(fmt);
if (fmt->str.len == 0)
{
*dst = *temp_p;
return;
}
temp_p->mvtype = MV_STR;
ch = (unsigned char *)temp_p->str.addr;
ct = temp_p->str.len;
cp = stringpool.free;
fncode = 0;
for (ff = (unsigned char *)fmt->str.addr , ff_top = ff + fmt->str.len ; ff < ff_top ; )
{
switch(*ff++)
{
case '+':
fncode |= PLUS;
break;
case '-':
fncode |= MINUS;
break;
case ',':
fncode |= COMMA;
break;
case 'T':
case 't':
fncode |= TRAIL;
break;
case 'P':
case 'p':
fncode |= PAREN;
break;
default:
rts_error(VARLSTCNT(6) ERR_FNUMARG, 4, fmt->str.len, fmt->str.addr, 1, --ff);
break;
}
}
if (0 != (fncode & PAREN) && 0 != (fncode & FNERROR))
rts_error(VARLSTCNT(4) ERR_FNARGINC, 2, fmt->str.len, fmt->str.addr);
else
{
sign = 0;
paren = FALSE;
if ('-' == *ch)
{
sign = '-';
ch++;
ct--;
}
if (0 != (fncode & PAREN))
{
if ('-' == sign)
{
*cp++ = '(';
sign = 0;
paren = TRUE;
}
else *cp++ = ' ';
}
/* Only add '+' if > 0 */
if (0 != (fncode & PLUS) && 0 == sign)
{ /* Need to make into num and check for int 0 in case was preprocessed by op_fnj3() */
MV_FORCE_NUM(temp_p);
if (0 == (temp_p->mvtype & MV_INT) || 0 != temp_p->m[1])
sign = '+';
}
if (0 != (fncode & MINUS) && '-' == sign)
sign = 0;
if (0 == (fncode & TRAIL) && 0 != sign)
*cp++ = sign;
if (0 != (fncode & COMMA))
{
comma = FALSE;
for (x = 0, t = ch; '.' != *t && ++x < ct; t++) ;
z = x;
if ((y = x % 3) > 0)
{
while (y-- > 0)
*cp++ = *ch++;
comma = TRUE;
}
for ( ; x / 3 != 0 ; x -= 3, cp += 3, ch +=3)
{
if (comma)
*cp++ = ',';
else
comma = TRUE;
memcpy(cp, ch, 3);
}
if (z < ct)
{
xx = ct - z;
memcpy(cp, ch, xx);
cp += xx;
}
} else
{
memcpy(cp, ch, ct);
cp += ct;
}
if (0 != (fncode & TRAIL))
{
if (sign != 0) *cp++ = sign;
else *cp++ = ' ';
}
if (0 != (fncode & PAREN))
{
if (paren) *cp++ = ')';
else *cp++ = ' ';
}
dst->mvtype = MV_STR;
dst->str.addr = (char *)stringpool.free;
dst->str.len = INTCAST(cp - stringpool.free);
stringpool.free = cp;
return;
}
GTMASSERT;
}
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_svput(int varnum, mval *v)
{
int i, ok, state;
error_def(ERR_UNIMPLOP);
error_def(ERR_TEXT);
error_def(ERR_INVECODEVAL);
error_def(ERR_SETECODE);
error_def(ERR_SYSTEMVALUE);
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 (dollar_zcompile.addr)
free (dollar_zcompile.addr);
dollar_zcompile.addr = (char *)malloc(v->str.len);
memcpy (dollar_zcompile.addr, v->str.addr, v->str.len);
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(v->str.len == 0)
{
/* set $zgbldir="" */
dpzgbini();
gd_header = NULL;
} else
{
gd_header = zgbldir(v);
dollar_zgbldir.str.len = v->str.len;
dollar_zgbldir.str.addr = v->str.addr;
s2pool(&dollar_zgbldir.str);
}
if (gv_currkey)
gv_currkey->base[0] = 0;
if (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 (dollar_zroutines.addr)
free (dollar_zroutines.addr);
dollar_zroutines.addr = (char *)malloc(v->str.len);
memcpy (dollar_zroutines.addr, v->str.addr, v->str.len);
dollar_zroutines.len = v->str.len;
break;
case SV_ZSOURCE:
MV_FORCE_STR(v);
dollar_zsource = v->str;
break;
case SV_ZTRAP:
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();
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);
gtmprompt.len = v->str.len < sizeof(prombuf) ? v->str.len : sizeof(prombuf);
memcpy(gtmprompt.addr,v->str.addr,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 */
}
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:
ok = 1;
if (!(v->mvtype & MV_STR))
ok = 0;
if (ok && v->str.addr[0] != '4')
ok = 0;
if (ok && v->str.addr[1] != '7')
ok = 0;
if ((' ' != v->str.addr[2]) && !ispunct(v->str.addr[2]))
ok = 0;
if (ok)
dollar_system.str = v->str;
else
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);
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;
default:
GTMASSERT;
}
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;
}
}
void op_fnfnumber(mval *src, mval *fmt, boolean_t use_fract, int fract, mval *dst)
{
boolean_t comma, paren;
int ct, x, xx, y, z;
unsigned char *ch, *cp, *ff, *ff_top, fncode, sign, *t;
if (!MV_DEFINED(fmt)) /* catch this up front so noundef mode can't cause trouble - so fmt no empty context */
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(2) ERR_FNUMARG, 0);
/* if the dst will be different than the src we'll build the new value in the string pool and repoint dst there,
* otherwise, dst will anyway become the same as src, therefore we can safely use dst as a "temporary" copy of src
*/
*dst = *src;
if (use_fract)
op_fnj3(dst, 0, fract, dst);
else
{
MV_FORCE_NUM(dst);
MV_FORCE_CANONICAL(dst); /* if the source operand is not a canonical number, force conversion */
}
assert (stringpool.free >= stringpool.base);
assert (stringpool.free <= stringpool.top);
/* assure there is adequate space for two string forms of a number as a local
* version of the src must be operated upon in order to get a canonical number
*/
MV_FORCE_STR(fmt);
MV_FORCE_STR(dst);
if (0 == fmt->str.len)
return;
ENSURE_STP_FREE_SPACE(MAX_NUM_SIZE * 2);
ch = (unsigned char *)dst->str.addr;
ct = dst->str.len;
cp = stringpool.free;
fncode = 0;
for (ff = (unsigned char *)fmt->str.addr, ff_top = ff + fmt->str.len; ff < ff_top;)
{
switch(*ff++)
{
case '+':
fncode |= PLUS;
break;
case '-':
fncode |= MINUS;
break;
case ',':
fncode |= COMMA;
break;
case 'T':
case 't':
fncode |= TRAIL;
break;
case 'P':
case 'p':
fncode |= PAREN;
break;
default:
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(6) ERR_FNUMARG, 4, fmt->str.len, fmt->str.addr, 1, --ff);
break;
}
}
if ((0 != (fncode & PAREN)) && (0 != (fncode & FNERROR)))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(4) ERR_FNARGINC, 2, fmt->str.len, fmt->str.addr);
else
{
sign = 0;
paren = FALSE;
if ('-' == *ch)
{
sign = '-';
ch++;
ct--;
}
if (0 != (fncode & PAREN))
{
if ('-' == sign)
{
*cp++ = '(';
sign = 0;
paren = TRUE;
}
else *cp++ = ' ';
}
/* Only add '+' if > 0 */
if ((0 != (fncode & PLUS)) && (0 == sign))
{ /* Need to make into num and check for int 0 in case was preprocessed by op_fnj3() */
MV_FORCE_NUM(dst);
if ((0 == (dst->mvtype & MV_INT)) || (0 != dst->m[1]))
sign = '+';
}
if ((0 != (fncode & MINUS)) && ('-' == sign))
sign = 0;
if ((0 == (fncode & TRAIL)) && (0 != sign))
*cp++ = sign;
if (0 != (fncode & COMMA))
{
comma = FALSE;
for (x = 0, t = ch; (('.' != *t) && (++x < ct)); t++)
;
z = x;
if ((y = x % 3) > 0)
{
while (y-- > 0)
*cp++ = *ch++;
comma = TRUE;
}
for ( ; (0 != (x / 3)); x -= 3, cp += 3, ch +=3)
{
if (comma)
*cp++ = ',';
else
comma = TRUE;
memcpy(cp, ch, 3);
}
if (z < ct)
{
xx = ct - z;
memcpy(cp, ch, xx);
cp += xx;
}
} else
{
memcpy(cp, ch, ct);
cp += ct;
}
if (0 != (fncode & TRAIL))
{
if (sign != 0) *cp++ = sign;
else *cp++ = ' ';
}
if (0 != (fncode & PAREN))
{
if (paren)*cp++ = ')';
else *cp++ = ' ';
}
dst->mvtype = MV_STR;
dst->str.addr = (char *)stringpool.free;
dst->str.len = INTCAST(cp - stringpool.free);
stringpool.free = cp;
return;
}
assertpro(FALSE);
}
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;
}
void op_fnj3(mval *src,int width,int fract,mval *dst)
{
int4 n, n1, m;
int w, digs, digs_used;
int sign;
static readonly int4 fives_table[9] =
{ 500000000, 50000000, 5000000, 500000, 50000, 5000, 500, 50, 5};
unsigned char *cp;
error_def(ERR_JUSTFRACT);
error_def(ERR_MAXSTRLEN);
if (width < 0)
width = 0;
else if (width > MAX_STRLEN)
rts_error(VARLSTCNT(1) ERR_MAXSTRLEN);
if (fract < 0)
rts_error(VARLSTCNT(1) ERR_JUSTFRACT);
w = width + MAX_NUM_SIZE + 2 + fract;
/* the literal two above accounts for the possibility
of inserting a zero and/or a minus with a width of zero */
if (w > MAX_STRLEN)
rts_error(VARLSTCNT(1) ERR_MAXSTRLEN);
MV_FORCE_NUM(src);
/* need to guarantee that the n2s call will not cause string pool overflow */
ENSURE_STP_FREE_SPACE(w);
sign = 0;
cp = stringpool.free;
if (src->mvtype & MV_INT)
{
n = src->m[1];
if (n < 0)
{
sign = 1;
n = -n;
}
/* Round if necessary */
if (fract < 3)
n += fives_table[fract + 6];
/* Compute digs, the number of non-zero leading digits */
if (n < 1000)
{
digs = 0;
/* if we have something like $j(-.01,0,1), the answer should be 0.0, not -0.0
so lets check for that here */
if (sign && fract < 4 && n / ten_pwr[3 - fract] == 0)
{
sign = 0;
n = 0;
} else
n *= 1000000;
} else if (n >= 1000000000)
{
digs = 7;
} else
{
for (digs = 6; n < 100000000 ; n *= 10 , digs--)
;
}
/* Do we need leading spaces? */
w = width - sign - (fract != 0) - fract - digs;
if (digs == 0)
w--;
if (w > 0)
{
memset(cp, ' ', w);
cp += w;
}
if (sign)
*cp++ = '-';
if (digs == 0)
*cp++ = '0';
else
{
/* It is possible that when rounding, that
we overflowed by one digit. In this case,
the left-most digit must be a "1".
Take care of this case first.
*/
if (digs == 7)
{
*cp++ = '1';
n -= 1000000000;
digs = 6;
}
for ( ; digs > 0 ; digs--)
{
n1 = n / 100000000;
*cp++ = n1 + '0';
n = (n - n1 * 100000000) * 10;
}
}
if (fract)
{
*cp++ = '.';
for (digs = fract ; digs > 0 && n != 0; digs--)
{
n1 = n / 100000000;
*cp++ = n1 + '0';
n = (n - n1 * 100000000) * 10;
}
if (digs)
{
memset(cp, '0', digs);
cp += digs;
}
}
} else
{
digs = src->e - MV_XBIAS;
m = src->m[0];
n = src->m[1];
sign = src->sgn;
w = digs + fract;
if (w < 18 && w >= 0)
{
if (w < 9)
{
n += fives_table[w];
if (n >= MANT_HI)
{
n1 = n / 10;
m = m / 10 + ((n - n1 * 10) * MANT_LO);
n = n1;
digs++;
}
}
else
{
m += fives_table[w - 9];
if (m >= MANT_HI)
{
m -= MANT_HI;
n++;
if (n >= MANT_HI)
{
n1 = n / 10;
m = m / 10 + ((n - n1 * 10) * MANT_LO);
n = n1;
digs++;
}
}
}
}
/* if we have something like $j(-.0001,0,1), the answer should be 0.0, not -0.0 */
if (digs <= - fract)
{
sign = 0;
n = m = 0;
}
w = width - fract - (fract != 0) - sign - (digs < 1 ? 1 : digs);
if (w > 0)
{
memset(cp, ' ', w);
cp += w;
}
if (sign)
*cp++ = '-';
digs_used = 0;
if (digs < 1)
*cp++ = '0';
else
{
for ( ; digs > 0 && (n != 0 || m != 0); digs--)
{
n1 = n / 100000000;
*cp++ = n1 + '0';
digs_used++;
if (digs_used == 9)
{
n = m;
m = 0;
} else
n = (n - n1 * 100000000) * 10;
}
if (digs > 0)
{
memset(cp, '0', digs);
cp += digs;
}
}
if (fract)
{
*cp++ = '.';
if (digs < 0)
{
digs = - digs;
if (digs > fract)
digs = fract;
memset(cp, '0', digs);
cp += digs;
fract -= digs;
}
for (digs = fract ; digs > 0 && (n != 0 || m != 0); digs--)
{
n1 = n / 100000000;
*cp++ = n1 + '0';
digs_used++;
if (digs_used == 9)
{
n = m;
m = 0;
} else
n = (n - n1 * 100000000) * 10;
}
if (digs)
{
memset(cp, '0', digs);
cp += digs;
}
}
}
dst->mvtype = MV_STR;
dst->str.addr = (char *)stringpool.free;
dst->str.len = INTCAST((char *)cp - dst->str.addr);
stringpool.free = cp;
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;
mv_stent *mv_zintcmd;
ABS_TIME cur_time, end_time;
# ifdef VMS
uint4 time[2];
int4 efn_mask, status;
# endif
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
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)
{
if (TREF(tpnotacidtime) * 1000 < ms)
TPNOTACID_CHECK(HANGSTR);
# if defined(DEBUG) && defined(UNIX)
if (gtm_white_box_test_case_enabled
&& (WBTEST_DEFERRED_TIMERS == gtm_white_box_test_case_number)
&& (3 > gtm_white_box_test_case_count)
&& (123000 == ms))
{
DEFER_INTERRUPTS(INTRPT_NO_TIMER_EVENTS);
DBGFPF((stderr, "OP_HANG: will sleep for 20 seconds\n"));
LONG_SLEEP(20);
DBGFPF((stderr, "OP_HANG: done sleeping\n"));
ENABLE_INTERRUPTS(INTRPT_NO_TIMER_EVENTS);
return;
}
if (gtm_white_box_test_case_enabled
&& (WBTEST_BREAKMPC == gtm_white_box_test_case_number)
&& (0 == gtm_white_box_test_case_count)
&& (999 == ms))
{
frame_pointer->old_frame_pointer->mpc = (unsigned char *)GTM64_ONLY(0xdeadbeef12345678)
NON_GTM64_ONLY(0xdead1234);
return;
}
/* Upon seeing a .999s hang this white-box test launches a timer that pops with a period of UTIL_OUT_SYSLOG_INTERVAL
* and prints a long message via util_out_ptr.
*/
if (gtm_white_box_test_case_enabled
&& (WBTEST_UTIL_OUT_BUFFER_PROTECTION == gtm_white_box_test_case_number)
&& (0 == gtm_white_box_test_case_count)
&& (999 == ms))
{
start_timer((TID)&util_out_syslog_dump, UTIL_OUT_SYSLOG_INTERVAL, util_out_syslog_dump, 0, NULL);
return;
}
# endif
sys_get_curr_time(&cur_time);
mv_zintcmd = find_mvstent_cmd(ZINTCMD_HANG, restart_pc, restart_ctxt, FALSE);
if (!mv_zintcmd)
add_int_to_abs_time(&cur_time, ms, &end_time);
else
{
end_time = mv_zintcmd->mv_st_cont.mvs_zintcmd.end_or_remain;
cur_time = sub_abs_time(&end_time, &cur_time); /* get remaing time to sleep */
if (0 <= cur_time.at_sec)
ms = (int4)(cur_time.at_sec * 1000 + cur_time.at_usec / 1000);
else
ms = 0; /* all done */
/* restore/pop previous zintcmd_active[ZINTCMD_HANG] hints */
TAREF1(zintcmd_active, ZINTCMD_HANG).restart_pc_last = mv_zintcmd->mv_st_cont.mvs_zintcmd.restart_pc_prior;
TAREF1(zintcmd_active, ZINTCMD_HANG).restart_ctxt_last
= mv_zintcmd->mv_st_cont.mvs_zintcmd.restart_ctxt_prior;
TAREF1(zintcmd_active, ZINTCMD_HANG).count--;
assert(0 <= TAREF1(zintcmd_active, ZINTCMD_HANG).count);
if (mv_chain == mv_zintcmd)
POP_MV_STENT(); /* just pop if top of stack */
else
{ /* flag as not active */
mv_zintcmd->mv_st_cont.mvs_zintcmd.command = ZINTCMD_NOOP;
mv_zintcmd->mv_st_cont.mvs_zintcmd.restart_pc_check = NULL;
}
if (0 == ms)
return; /* done HANGing */
}
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)
/* given the bounds of a particular subscript (assumed correct), we convert the subscript into
* a form that mimics the GDS representation of that subscript
*/
boolean_t convert_key_to_db(mval *gvn, int start, int stop, gv_key *gvkey, unsigned char **key)
{
mval tmpval, *mvptr, dollarcharmval;
int isrc;
char strbuff[MAX_KEY_SZ + 1], *str, *str_top;
char fnname[MAX_LEN_FOR_CHAR_FUNC], *c;
boolean_t is_zchar;
int4 num;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (ISDIGIT_ASCII(gvn->str.addr[start]) ||
'-' == gvn->str.addr[start] || '+' == gvn->str.addr[start] || '.' == gvn->str.addr[start])
{ /* convert a number */
tmpval.str.addr = &gvn->str.addr[start];
tmpval.str.len = stop - start;
tmpval.mvtype = MV_STR;
mvptr = &tmpval;
MV_FORCE_NUM(mvptr);
if (MVTYPE_IS_NUM_APPROX(tmpval.mvtype))
return FALSE;
mval2subsc(&tmpval, gvkey, gv_cur_region->std_null_coll);
} else
{ /* It's a string. We need to accept strings, $CHAR args, and $ZCHAR args. */
str = &strbuff[0];
str_top = &strbuff[0] + MAX_KEY_SZ + 1;
/* MV_NUM_APPROX needed by mval2subsc to skip val_iscan call */
tmpval.mvtype = (MV_STR | MV_NUM_APPROX);
for (isrc = start; isrc < stop; )
{
if ('_' == gvn->str.addr[isrc])
{ /* We can skip this case, since we're already "appending"
* the strings on the lhs to the string on the rhs. */
isrc++;
} else if ('$' == gvn->str.addr[isrc])
{ /* We determine if what comes after is a Char or a ZCHar,
* and copy over accordingly */
c = &fnname[0];
isrc++; /* skip the '$' */
while ('(' != gvn->str.addr[isrc])
*c++ = TOUPPER(gvn->str.addr[isrc++]);
*c = '\0';
assert(strlen(c) <= MAX_LEN_FOR_CHAR_FUNC - 1);
if (!MEMCMP_LIT(fnname, "ZCHAR") || !MEMCMP_LIT(fnname, "ZCH"))
is_zchar = TRUE;
else if (!MEMCMP_LIT(fnname, "CHAR") || !MEMCMP_LIT(fnname, "C"))
is_zchar = FALSE;
else
assert(FALSE);
/* Parse the arguments */
isrc++; /* skip the '(' */
while (TRUE)
{ /* Inside the argument list for $[Z]CHAR */
/* STRTOUL will stop at the ',' or ')' */
num = (int4)STRTOUL(&gvn->str.addr[isrc], NULL, 10);
# ifdef UNICODE_SUPPORTED
if (!is_zchar && is_gtm_chset_utf8)
op_fnchar(2, &dollarcharmval, num);
else
# endif
op_fnzchar(2, &dollarcharmval, num);
assert(MV_IS_STRING(&dollarcharmval));
if (dollarcharmval.str.len)
{
if (str + dollarcharmval.str.len > str_top)
/* String overflows capacity. */
return FALSE;
memcpy(str, dollarcharmval.str.addr, dollarcharmval.str.len);
str += dollarcharmval.str.len;
}
/* move on to the next argument */
while (',' != gvn->str.addr[isrc] && ')' != gvn->str.addr[isrc])
isrc++;
if (',' == gvn->str.addr[isrc])
isrc++;
else
{
assert(')' == gvn->str.addr[isrc]);
isrc++; /* skip ')' */
break;
}
}
} else if ('"' == gvn->str.addr[isrc])
{ /* Assume valid string. */
isrc++;
while (isrc < stop && !('"' == gvn->str.addr[isrc] && '"' != gvn->str.addr[isrc+1]))
{
if (str == str_top)
/* String overflows capacity. */
return FALSE;
if ('"' == gvn->str.addr[isrc] && '"' == gvn->str.addr[isrc+1])
{
*str++ = '"';
isrc += 2;
} else
*str++ = gvn->str.addr[isrc++];
}
isrc++; /* skip over '"' */
} else
assert(FALSE);
}
tmpval.str.addr = strbuff;
tmpval.str.len = str - strbuff;
DEBUG_ONLY(TREF(skip_mv_num_approx_assert) = TRUE;)
mval2subsc(&tmpval, gvkey, gv_cur_region->std_null_coll);
DEBUG_ONLY(TREF(skip_mv_num_approx_assert) = FALSE;)
}
void op_fnzdate(mval *src, mval *fmt, mval *mo_str, mval *day_str, mval *dst)
{
unsigned char ch, *fmtptr, *fmttop, *i, *outptr, *outtop, *outpt1;
int cent, day, dow, month, nlen, outlen, time, year;
unsigned int n;
mval temp_mval;
static readonly unsigned char montab[] = {31,28,31,30,31,30,31,31,30,31,30,31};
static readonly unsigned char default1[] = DEFAULT1;
static readonly unsigned char default2[] = DEFAULT2;
static readonly unsigned char default3[] = DEFAULT3;
static readonly unsigned char defmonlst[] = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC";
static readonly unsigned char defdaylst[] = "SUNMONTUEWEDTHUFRISAT";
#if defined(BIGENDIAN)
static readonly int comma = (((int)',') << 24);
#else
static readonly int comma = ',';
#endif
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
MV_FORCE_NUM(src);
MV_FORCE_STR(fmt);
MV_FORCE_STR(mo_str);
MV_FORCE_STR(day_str);
ENSURE_STP_FREE_SPACE(ZDATE_MAX_LEN);
time = 0;
outlen = src->str.len;
if ((src->mvtype & MV_STR) && (src->mvtype & MV_NUM_APPROX))
{
for (outptr = (unsigned char *)src->str.addr, outtop = outptr + outlen; outptr < outtop; )
{
if (',' == *outptr++)
{
outlen = outptr - (unsigned char *)src->str.addr - 1;
temp_mval.mvtype = MV_STR;
temp_mval.str.addr = (char *)outptr;
temp_mval.str.len = INTCAST(outtop - outptr);
s2n(&temp_mval);
time = MV_FORCE_INTD(&temp_mval);
if ((0 > time) || (MAX_TIME < time))
rts_error(VARLSTCNT(4) ERR_ZDATEBADTIME, 2, temp_mval.str.len, temp_mval.str.addr);
break;
}
}
}
day = (int)MV_FORCE_INTD(src);
if ((MAX_DATE < day) || (MIN_DATE > day))
{
MV_FORCE_STR(src);
rts_error(VARLSTCNT(4) ERR_ZDATEBADDATE, 2, outlen, src->str.addr);
}
day += DAYS_MOST_YEARS;
dow = ((day + ADJUST_TO_1900) % DAYS_IN_WEEK) + 1;
for (cent = DAYS_BASE_TO_1900, n = ADJUST_TO_1900; cent < day; cent += DAYS_IN_CENTURY, n++)
day += (0 < (n % COMMON_LEAP_CYCLE));
year = day / DAYS_IN_FOUR_YEARS;
day = day - (year * DAYS_IN_FOUR_YEARS);
year = (year * COMMON_LEAP_CYCLE) + BASE_YEAR;
if (DAYS_BEFORE_LEAP == day)
{
day = MIN_DAYS_IN_MONTH + 1;
month = 2;
} else
{
if (DAYS_BEFORE_LEAP < day)
day--;
month = day / DAYS_MOST_YEARS;
year += month;
day -= (month * DAYS_MOST_YEARS);
for (i = montab; day >= *i; day -= *i++)
;
month = (int)((i - montab)) + 1;
day++;
assert((0 < month) && (MONTHS_IN_YEAR >= month));
}
if ((0 == fmt->str.len) || ((1 == fmt->str.len) && ('1' == *fmt->str.addr)))
{
if (!TREF(zdate_form) || ((1 == TREF(zdate_form)) && (PIVOT_MILLENIUM > year)))
{
fmtptr = default1;
fmttop = fmtptr + STR_LIT_LEN(DEFAULT1);
} else
{
fmtptr = default3;
fmttop = fmtptr + STR_LIT_LEN(DEFAULT3);
}
} else if ((1 == fmt->str.len) && ('2' == *fmt->str.addr))
{
fmtptr = default2;
fmttop = fmtptr + STR_LIT_LEN(DEFAULT2);
} else
{
fmtptr = (unsigned char *)fmt->str.addr;
fmttop = fmtptr + fmt->str.len;
}
outlen = (int)(fmttop - fmtptr);
if (outlen >= ZDATE_MAX_LEN)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
outptr = stringpool.free;
outtop = outptr + ZDATE_MAX_LEN;
temp_mval.mvtype = MV_STR;
assert(0 <= time);
nlen = 0;
while (fmtptr < fmttop)
{
switch (ch = *fmtptr++) /* NOTE assignment */
{
case '/':
case ':':
case '.':
case ',':
case '-':
case ' ':
case '*':
case '+':
case ';':
*outptr++ = ch;
continue;
case 'M':
ch = *fmtptr++;
if ('M' == ch)
{
n = month;
nlen = 2;
break;
}
if (('O' != ch) || ('N' != *fmtptr++))
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
if (0 == mo_str->str.len)
{
temp_mval.str.addr = (char *)&defmonlst[(month - 1) * LEN_OF_3_CHAR_ABBREV];
temp_mval.str.len = LEN_OF_3_CHAR_ABBREV;
nlen = -LEN_OF_3_CHAR_ABBREV;
} else
{
UNICODE_ONLY(gtm_utf8_mode ? op_fnp1(mo_str, comma, month, &temp_mval) :
op_fnzp1(mo_str, comma, month, &temp_mval));
VMS_ONLY(op_fnzp1(mo_str, comma, month, &temp_mval, TRUE));
nlen = -temp_mval.str.len;
outlen += - LEN_OF_3_CHAR_ABBREV - nlen;
if (outlen >= ZDATE_MAX_LEN)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
}
break;
case 'D':
ch = *fmtptr++;
if ('D' == ch)
{
n = day;
nlen = 2;
break;
}
if (('A' != ch) || ('Y' != *fmtptr++))
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
if (0 == day_str->str.len)
{
temp_mval.str.addr = (char *)&defdaylst[(dow - 1) * LEN_OF_3_CHAR_ABBREV];
temp_mval.str.len = LEN_OF_3_CHAR_ABBREV;
nlen = -LEN_OF_3_CHAR_ABBREV;
} else
{
UNICODE_ONLY(gtm_utf8_mode ? op_fnp1(day_str, comma, dow, &temp_mval)
: op_fnzp1(day_str, comma, dow, &temp_mval));
VMS_ONLY(op_fnzp1(day_str, comma, dow, &temp_mval, TRUE));
nlen = -temp_mval.str.len;
outlen += - LEN_OF_3_CHAR_ABBREV - nlen;
if (outlen >= ZDATE_MAX_LEN)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
}
break;
case 'Y':
ch = *fmtptr++;
n = year;
if ('Y' == ch)
{
for (nlen = 2; (MAX_YEAR_DIGITS >=nlen) && fmtptr < fmttop; ++nlen, fmtptr++)
if ('Y' != *fmtptr)
break;
} else
{
if (('E' != ch) || ('A' != *fmtptr++) || ('R' != *fmtptr++))
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
nlen = 4;
}
break;
case '1':
if ('2' != *fmtptr++)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
nlen = 2;
n = time / SECONDS_PER_HOUR;
n = ((n + HOURS_PER_AM_OR_PM - 1) % HOURS_PER_AM_OR_PM) + 1;
break;
case '2':
if ('4' != *fmtptr++)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
nlen = 2;
n = time / SECONDS_PER_HOUR;
break;
case '6':
if ('0' != *fmtptr++)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
nlen = 2;
n = time;
n /= MINUTES_PER_HOUR;
n %= MINUTES_PER_HOUR;
break;
case 'S':
if ('S' != *fmtptr++)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
nlen = 2;
n = time % SECONDS_PER_MINUTE;
break;
case 'A':
if ('M' != *fmtptr++)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
*outptr++ = (time < (HOURS_PER_AM_OR_PM * SECONDS_PER_HOUR)) ? 'A' : 'P';
*outptr++ = 'M';
continue;
default:
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
}
if (nlen > 0)
{
outptr += nlen;
outpt1 = outptr;
while (nlen-- > 0)
{
*--outpt1 = '0' + (n % 10);
n /= 10;
}
} else
{
outpt1 = (unsigned char *)temp_mval.str.addr;
while (nlen++ < 0)
*outptr++ = *outpt1++;
}
}
if (fmtptr > fmttop)
rts_error(VARLSTCNT(1) ERR_ZDATEFMT);
dst->mvtype = MV_STR;
dst->str.addr = (char *)stringpool.free;
dst->str.len = INTCAST((char *)outptr - dst->str.addr);
stringpool.free = outptr;
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.
*
* The actual hang duration should be NO LESS than the specified
* duration for specified durations greater than .001 seconds.
* Certain applications depend on this assumption.
*
* Arguments:
* num - time to sleep
*
* Return:
* none
* ------------------------------------------
*/
void op_hang(mval* num)
{
int ms;
double tmp;
mv_stent *mv_zintcmd;
ABS_TIME cur_time, end_time;
# ifdef VMS
uint4 time[2];
int4 efn_mask, status;
# endif
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
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 */
{
tmp = mval2double(num) * (double)1000;
ms = ((double)MAXPOSINT4 >= tmp) ? (int)tmp : (int)MAXPOSINT4;
}
if (ms)
{
if (TREF(tpnotacidtime) * 1000 < ms)
TPNOTACID_CHECK(HANGSTR);
# if defined(DEBUG) && defined(UNIX)
if (WBTEST_ENABLED(WBTEST_DEFERRED_TIMERS) && (3 > gtm_white_box_test_case_count) && (123000 == ms))
{
DEFER_INTERRUPTS(INTRPT_NO_TIMER_EVENTS);
DBGFPF((stderr, "OP_HANG: will sleep for 20 seconds\n"));
LONG_SLEEP(20);
DBGFPF((stderr, "OP_HANG: done sleeping\n"));
ENABLE_INTERRUPTS(INTRPT_NO_TIMER_EVENTS);
return;
}
if (WBTEST_ENABLED(WBTEST_BREAKMPC)&& (0 == gtm_white_box_test_case_count) && (999 == ms))
{
frame_pointer->old_frame_pointer->mpc = (unsigned char *)GTM64_ONLY(0xdeadbeef12345678)
NON_GTM64_ONLY(0xdead1234);
return;
}
if (WBTEST_ENABLED(WBTEST_UTIL_OUT_BUFFER_PROTECTION) && (0 == gtm_white_box_test_case_count) && (999 == ms))
{ /* Upon seeing a .999s hang this white-box test launches a timer that pops with a period of
* UTIL_OUT_SYSLOG_INTERVAL and prints a long message via util_out_ptr.
*/
start_timer((TID)&util_out_syslog_dump, UTIL_OUT_SYSLOG_INTERVAL, util_out_syslog_dump, 0, NULL);
return;
}
# endif
sys_get_curr_time(&cur_time);
mv_zintcmd = find_mvstent_cmd(ZINTCMD_HANG, restart_pc, restart_ctxt, FALSE);
if (!mv_zintcmd)
add_int_to_abs_time(&cur_time, ms, &end_time);
else
{
end_time = mv_zintcmd->mv_st_cont.mvs_zintcmd.end_or_remain;
cur_time = sub_abs_time(&end_time, &cur_time); /* get remaing time to sleep */
if (0 <= cur_time.at_sec)
ms = (int4)(cur_time.at_sec * 1000 + cur_time.at_usec / 1000);
else
ms = 0; /* all done */
/* restore/pop previous zintcmd_active[ZINTCMD_HANG] hints */
TAREF1(zintcmd_active, ZINTCMD_HANG).restart_pc_last = mv_zintcmd->mv_st_cont.mvs_zintcmd.restart_pc_prior;
TAREF1(zintcmd_active, ZINTCMD_HANG).restart_ctxt_last
= mv_zintcmd->mv_st_cont.mvs_zintcmd.restart_ctxt_prior;
TAREF1(zintcmd_active, ZINTCMD_HANG).count--;
assert(0 <= TAREF1(zintcmd_active, ZINTCMD_HANG).count);
if (mv_chain == mv_zintcmd)
POP_MV_STENT(); /* just pop if top of stack */
else
{ /* flag as not active */
mv_zintcmd->mv_st_cont.mvs_zintcmd.command = ZINTCMD_NOOP;
mv_zintcmd->mv_st_cont.mvs_zintcmd.restart_pc_check = NULL;
}
if (0 == ms)
return; /* done HANGing */
}
# ifdef UNIX
if (ms < 10)
SLEEP_USEC(ms * 1000, TRUE); /* Finish the sleep if it is less than 10ms. */
else
hiber_start(ms);
# elif defined(VMS)
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_csa(CSA_ARG(NULL) VARLSTCNT(8) ERR_SYSCALL, 5, RTS_ERROR_LITERAL("$setimr"), CALLFROM, status);
if (SS$_NORMAL != (status = sys$wflor(efn_outofband, efn_mask)))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(8) ERR_SYSCALL, 5, RTS_ERROR_LITERAL("$wflor"), CALLFROM, status);
if (outofband)
{
if (SS$_WASCLR == (status = sys$readef(efn_timer, &efn_mask)))
{
if (SS$_NORMAL != (status = sys$cantim(&time, 0)))
rts_error_csa(CSA_ARG(NULL) VARLSTCNT(8) ERR_SYSCALL, 5, RTS_ERROR_LITERAL("$cantim"),
CALLFROM, status);
} else
assertpro(SS$_WASSET == status);
}
# endif
} else
rel_quant();
if (outofband)
{
PUSH_MV_STENT(MVST_ZINTCMD);
mv_chain->mv_st_cont.mvs_zintcmd.end_or_remain = end_time;
mv_chain->mv_st_cont.mvs_zintcmd.restart_ctxt_check = restart_ctxt;
mv_chain->mv_st_cont.mvs_zintcmd.restart_pc_check = restart_pc;
/* save current information from zintcmd_active */
mv_chain->mv_st_cont.mvs_zintcmd.restart_ctxt_prior = TAREF1(zintcmd_active, ZINTCMD_HANG).restart_ctxt_last;
mv_chain->mv_st_cont.mvs_zintcmd.restart_pc_prior = TAREF1(zintcmd_active, ZINTCMD_HANG).restart_pc_last;
TAREF1(zintcmd_active, ZINTCMD_HANG).restart_pc_last = restart_pc;
TAREF1(zintcmd_active, ZINTCMD_HANG).restart_ctxt_last = restart_ctxt;
TAREF1(zintcmd_active, ZINTCMD_HANG).count++;
mv_chain->mv_st_cont.mvs_zintcmd.command = ZINTCMD_HANG;
outofband_action(FALSE);
}
return;
}
void flt_mod (mval *u, mval *v, mval *q)
{
int exp;
int4 z, x;
mval w; /* temporary mval for division result */
mval y; /* temporary mval for extended precision promotion
to prevent modifying caller's data */
mval *u_orig; /* original (caller's) value of u */
error_def(ERR_DIVZERO);
u_orig = u;
MV_FORCE_NUM(u);
MV_FORCE_NUM(v);
if ((v->mvtype & MV_INT) != 0 && v->m[1] == 0)
rts_error(VARLSTCNT(1) ERR_DIVZERO);
if ((u->mvtype & MV_INT & v->mvtype) != 0)
{
/* Both are INT's; use shortcut. */
q->mvtype = MV_NM | MV_INT;
eb_int_mod(u->m[1], v->m[1], q->m);
return;
}
else if ((u->mvtype & MV_INT) != 0)
{
/* u is INT; promote to extended precision for compatibility with v. */
y = *u;
promote(&y); /* y will be normalized, but not in canonical form */
u = &y; /* this is why we need u_orig */
}
else if ((v->mvtype & MV_INT) != 0)
{
/* v is INT; promote to extended precision for compatibility with u. */
y = *v;
promote(&y);
v = &y;
}
/* At this point, both u and v are in extended precision format. */
/* Set w = floor(u/v). */
op_div (u, v, &w);
if ((w.mvtype & MV_INT) != 0)
promote(&w);
exp = w.e;
if (exp <= MV_XBIAS)
{
/* Magnitude of w, floor(u/v), is < 1. */
if (u->sgn != v->sgn && w.m[1] != 0 && exp >= EXPLO)
{
/* Signs differ (=> floor(u/v) < 0) and (w != 0) and (no underflow) => floor(u/v) == -1 */
w.sgn = 1;
w.e = MV_XBIAS + 1;
w.m[1] = MANT_LO;
w.m[0] = 0;
}
else
{
/* Signs same (=> floor(u/v) >= 0) or (w == 0) or (underflow) => floor(u/v) == 0 */
*q = *u_orig; /* u - floor(u/v)*v == u - 0*v == u */
return;
}
}
else if (exp < EXP_IDX_BIAL)
{
z = ten_pwr[EXP_IDX_BIAL - exp];
x = (w.m[1]/z)*z;
if (u->sgn != v->sgn && (w.m[1] != x || w.m[0] != 0))
{
w.m[0] = 0;
w.m[1] = x + z;
if (w.m[1] >= MANT_HI)
{
w.m[0] = w.m[0]/10 + (w.m[1]%10)*MANT_LO;
w.m[1] /= 10;
w.e++;
}
}
else
{
w.m[0] = 0;
w.m[1] = x;
}
}
else if (exp < EXP_IDX_BIAQ)
{
z = ten_pwr[EXP_IDX_BIAQ - exp];
x = (w.m[0]/z)*z;
if (u->sgn != v->sgn && w.m[0] != x)
{
w.m[0] = x + z;
if (w.m[0] >= MANT_HI)
{
w.m[0] -= MANT_HI;
w.m[1]++;
}
}
else
{
w.m[0] = x;
}
}
op_mul (&w, v, &w); /* w = w*v = floor(u/v)*v */
op_sub (u_orig, &w, q); /* q = u - w = u - floor(u/v)*v */
}
