int f_char(oprtype *a, opctype op)
{
boolean_t all_lits;
unsigned char *base, *outptr, *tmpptr;
int argc, ch, char_len, size;
mval v;
oprtype *argp, argv[CHARMAXARGS];
triple *curr, *last, *root;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
/* If we are not in UTF8 mode, we need to reroute to the $ZCHAR function to handle things correctly */
if (!gtm_utf8_mode)
return f_zchar(a, op);
all_lits = TRUE;
argp = &argv[0];
argc = 0;
for (;;)
{
if (EXPR_FAIL == expr(argp, MUMPS_INT))
return FALSE;
assert(TRIP_REF == argp->oprclass);
if (OC_ILIT != argp->oprval.tref->opcode)
all_lits = FALSE;
argc++;
argp++;
if (TK_COMMA != TREF(window_token))
break;
advancewindow();
if (CHARMAXARGS <= argc)
{
stx_error(ERR_FCHARMAXARGS);
return FALSE;
}
}
if (all_lits)
{ /* All literals, build the function inline */
size = argc * GTM_MB_LEN_MAX;
ENSURE_STP_FREE_SPACE(size);
base = stringpool.free;
argp = &argv[0];
for (outptr = base, char_len = 0; argc > 0; --argc, argp++)
{ /* For each wide char value, convert to unicode chars in stringpool buffer */
ch = argp->oprval.tref->operand[0].oprval.ilit;
if (0 <= ch)
{ /* As per the M standard, negative code points should map to no characters */
tmpptr = UTF8_WCTOMB(ch, outptr);
assert(tmpptr - outptr <= 4);
if (tmpptr != outptr)
++char_len; /* yet another valid character. update the character length */
else if (!badchar_inhibit)
stx_error(ERR_INVDLRCVAL, 1, ch);
outptr = tmpptr;
}
}
stringpool.free = outptr;
MV_INIT_STRING(&v, outptr - base, base);
v.str.char_len = char_len;
v.mvtype |= MV_UTF_LEN;
CLEAR_MVAL_BITS(&v);
s2n(&v);
*a = put_lit(&v);
return TRUE;
}
root = maketriple(op);
root->operand[0] = put_ilit(argc + 1);
last = root;
argp = &argv[0];
for (; argc > 0 ;argc--, argp++)
{
curr = newtriple(OC_PARAMETER);
curr->operand[0] = *argp;
last->operand[1] = put_tref(curr);
last = curr;
}
ins_triple(root);
*a = put_tref(root);
return TRUE;
}
int m_write(void)
{
char *cp;
int lnx;
mval lit;
mstr *msp;
oprtype *oprptr, x;
triple *litlst[128], **llptr, **ltop, **ptx, *ref, *t1;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
llptr = litlst;
ltop = 0;
*llptr = 0;
for (;;)
{
devctlexp = FALSE;
switch (TREF(window_token))
{
case TK_ASTERISK:
advancewindow();
if (EXPR_FAIL == expr(&x, MUMPS_INT))
return FALSE;
assert(TRIP_REF == x.oprclass);
ref = newtriple(OC_WTONE);
ref->operand[0] = x;
STO_LLPTR((OC_ILIT == x.oprval.tref->opcode) ? ref : 0);
break;
case TK_QUESTION:
case TK_EXCLAIMATION:
case TK_HASH:
case TK_SLASH:
if (!rwformat())
return FALSE;
STO_LLPTR(0);
break;
default:
switch (expr(&x, MUMPS_STR))
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
assert(TRIP_REF == x.oprclass);
if (devctlexp)
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR(0);
} else if (x.oprval.tref->opcode == OC_CAT)
wrtcatopt(x.oprval.tref, &llptr, LITLST_TOP);
else
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR((OC_LIT == x.oprval.tref->opcode) ? ref : 0);
}
break;
case EXPR_INDR:
make_commarg(&x, indir_write);
STO_LLPTR(0);
break;
default:
assert(FALSE);
}
break;
}
if (TK_COMMA != TREF(window_token))
break;
advancewindow();
if (LITLST_TOP <= llptr)
{
*++llptr = 0;
ltop = llptr;
llptr = 0;
}
}
STO_LLPTR(0);
if (ltop)
llptr = ltop;
for (ptx = litlst ; ptx < llptr ; ptx++)
{
if (*ptx && *(ptx + 1))
{
lit.mvtype = MV_STR;
lit.str.addr = cp = (char *)stringpool.free;
CLEAR_MVAL_BITS(&lit);
for (t1 = ref = *ptx++ ; ref ; ref = *ptx++)
{
if (OC_WRITE == ref->opcode)
{
msp = &(ref->operand[0].oprval.tref->operand[0].oprval.mlit->v.str);
lnx = msp->len;
ENSURE_STP_FREE_SPACE(lnx);
memcpy(cp, msp->addr, lnx);
cp += lnx;
} else
{
assert(OC_WTONE == ref->opcode);
ENSURE_STP_FREE_SPACE(1);
*cp++ = ref->operand[0].oprval.tref->operand[0].oprval.ilit;
}
ref->operand[0].oprval.tref->opcode = OC_NOOP;
ref->opcode = OC_NOOP;
ref->operand[0].oprval.tref->operand[0].oprclass = NO_REF;
ref->operand[0].oprclass = NO_REF;
}
ptx--;
stringpool.free = (unsigned char *) cp;
lit.str.len = INTCAST(cp - lit.str.addr);
t1->opcode = OC_WRITE;
t1->operand[0] = put_lit(&lit);
}
}
return TRUE;
}
