//***********************************************************************
// $TEXT(entryref)
//
// the entire string "entryref" is passed in one variable, eval it here
//
short Dtext(u_char *ret_buffer, cstring *str) // $TEXT()
{ int i = 0; // a handy int
int j = 0; // and another
u_char slen; // saved length
short s; // for functions
int off = 1; // line offset
u_char rou[4+MAX_NAME_BYTES]; // routine name
u_char tag[4+MAX_NAME_BYTES]; // the tag
cstring *cr; // the rou
cstring *ct; // and the tag
ret_buffer[0] = '\0'; // JIC
ct = (cstring *) &tag[0]; // use it this way
cr = (cstring *) &rou[0]; // ditto
ct->len = 0; // assume no tag
cr->len = 0; // no routine for now
if (bcmp("+0\0", str->buf, 3) == 0) // $T(+0) ?
{ for (i = 0; i < MAX_NAME_BYTES; i++) // copy rou name
{ if (!partab.jobtab->dostk[partab.jobtab->cur_do].rounam.var_cu[i])
break; // quit when done
ret_buffer[i] =
partab.jobtab->dostk[partab.jobtab->cur_do].rounam.var_cu[i]; // copy
}
ret_buffer[i] = '\0'; // null terminate
return (short) i; // and exit
}
if ((str->buf[i] != '+') && (str->buf[i] != '^')) // is there a tag
{ while (j < MAX_NAME_BYTES)
{ if ((i == 0) && (str->buf[i] == '%')) // leading %
{ ct->buf[j++] = str->buf[i++]; // copy it
continue; // and go for more
}
if (isalnum(str->buf[i]) == 0) break; // done
ct->buf[j++] = str->buf[i++]; // copy it
}
ct->buf[j] = '\0'; // null terminate tag
ct->len = j; // save the length
off = 0; // change offset to zero
while ((str->buf[i] != '+') &&
(str->buf[i] != '^') &&
(str->buf[i] != '\0')) i++; // skip to + ^ or null
} // end tag processing
if (str->buf[i] == '+') // if we have a plus
{ off = 0; // clear offset
i++; // skip the +
while (isdigit(str->buf[i]) != 0) // for all digits
off = (off * 10) + (str->buf[i++] - '0'); // extract the offset
} // end offset stuf
if ((str->buf[i] != '^') && (str->buf[i] != '\0'))
return -(ERRMLAST + ERRZ12); // complain
j = 0; // clear rou ptr
if (str->buf[i] == '^') // routine name
{ i++; // skip the ^
while (j < MAX_NAME_BYTES)
{ if ((j == 0) && (str->buf[i] == '%')) // leading %
{ cr->buf[j++] = str->buf[i++]; // copy it
continue; // and go for more
}
if (isalnum(str->buf[i]) == 0) break; // done
cr->buf[j++] = str->buf[i++]; // copy it
}
cr->buf[j] = '\0'; // null terminate rou
cr->len = j; // save the length
}
else // we need the current routine
{ for (j = 0; j < MAX_NAME_BYTES; j++)
if ((cr->buf[j] =
partab.jobtab->dostk[partab.jobtab->cur_do].rounam.var_cu[j])
== '\0') break; // copy till done
cr->buf[j] = '\0'; // null terminate rou
cr->len = j; // save the length
}
if (cr->len == 0) return 0; // no routine supplied -> null
if ((ct->len == 0) && (!off)) // just the name reqd?
return mcopy(cr->buf, ret_buffer, cr->len); // return the name
X_set("$ROUTINE", &partab.src_var.name.var_cu[0], 8); // setup for DB_Get
partab.src_var.volset = partab.jobtab->rvol; // vol
partab.src_var.uci = partab.jobtab->ruci; // uci
if (cr->buf[0] == '%') // manager routine?
partab.src_var.uci = 1; // point there
partab.src_var.slen = 0; // init key size
s = UTIL_Key_Build(cr, &partab.src_var.key[0]); // first key
if (s < 0) return s; // die on error
slen = s; // save key size
if (ct->len == 0) // no tag?
{ ct->len = itocstring(ct->buf, off); // cstring off
s = UTIL_Key_Build(ct,
&partab.src_var.key[slen]); // next key
if (s < 0) return s; // die on error
partab.src_var.slen = s + slen; // save key size
s = DB_Get(&partab.src_var, ret_buffer); // get it
if (s < 0)
{ ret_buffer[0] = '\0'; // nothing
s = 0; // zero length
}
return s; // and return it
}
for (j = 1; ; j++) // need to read all lines
{ cr->len = itocstring(cr->buf, j); // cstring j
s = UTIL_Key_Build(cr,
&partab.src_var.key[slen]); // next key
if (s < 0) return s; // die on error
partab.src_var.slen = s + slen; // save key size
s = DB_Get(&partab.src_var, ret_buffer); // get it
if (s < 0)
{ ret_buffer[0] = '\0'; // nothing
return 0; // zero length
}
for (i = 0; i < ct->len; i++) // check the tag
if (ret_buffer[i] != ct->buf[i]) break; // quit if different
if (i < ct->len) continue; // go for next if no match
if ((ret_buffer[i] != ' ') && // must be space
(ret_buffer[i] != '(') && // or (
(ret_buffer[i] != '\0')) continue; // or null
if (off == 0) return s; // no offset - all done
j = j + off; // add the offset
cr->len = itocstring(cr->buf, j); // cstring j
s = UTIL_Key_Build(cr,
&partab.src_var.key[slen]); // next key
if (s < 0) return s; // die on error
partab.src_var.slen = s + slen; // save key size
s = DB_Get(&partab.src_var, ret_buffer); // get it
if (s < 0)
{ ret_buffer[0] = '\0'; // nothing
s = 0; // zero length
}
return s; // done
}
}
short buildmvar(mvar *var, int nul_ok, int asp) // build an mvar
{ u_char type; // variable type
int subs; // subscript count
int i; // a handy int
cstring *ptr; // and a handy pointer
short s; // for returns
chr_q *vt; // var table pointer
rbd *p; // a handy pointer
mvar *ind; // ind mvar ptr
type = *mumpspc++; // get the type
if (type < TYPVARNAKED) // subs in type
{ subs = (type & TYPMAXSUB); // the low bits
type = (type & ~TYPMAXSUB); // and the type
}
else
subs = *mumpspc++; // get in line
var->volset = 0; // default vol set
var->uci = (type < TYPVARGBL) ?
UCI_IS_LOCALVAR : 0; // assume local var or uci 0
var->slen = 0; // and no subscripts
if (type == TYPVARNAKED) // if it's a naked
{ if ( partab.jobtab->last_ref.name.var_qu == 0)
return (-ERRM1); // say "Naked indicator undef"
i = UTIL_Key_Last( &partab.jobtab->last_ref); // start of last key
if (i < 0) return (-ERRM1); // say "Naked indicator undef"
bcopy( &(partab.jobtab->last_ref), var,
sizeof(var_u) + 5 + i); // copy naked naked
var->slen = (u_char) i; // stuf in the count
}
else if (type == TYPVARIND) // it's an indirect
{ ind = (mvar *) astk[asp-subs-1]; // point at mvar so far
bcopy(ind, var, ind->slen + sizeof(var_u) + 5); // copy it in
}
else if ((type & TYPVARIDX) && // if it's the index type
(type < TYPVARGBL)) // and it's local
{ i = *mumpspc++; // get the index
if (i < 255) // can't do the last one
{ var->volset = i + 1; // save the index (+ 1)
var->name.var_qu = 0; // clear the name
}
else
{ p = (rbd *) (partab.jobtab->dostk[partab.jobtab->cur_do].routine);
vt = (chr_q *) (((u_char *) p) + p->var_tbl); // point at var table
var->name.var_qu = vt[i]; // get the var name
}
}
else
{ bcopy( mumpspc, &var->name, 8);
mumpspc += 8;
//var->name = *((var_u *)mumpspc)++; // get the variable name
}
for (i = 0; i < subs; i++) // for each subscript
{ ptr = (cstring *) astk[asp-subs+i]; // point at the string
if ((ptr->len == 0) && // if it's a null
((!nul_ok) || (i != (subs-1)))) // not ok or not last subs
return (-(ERRZ16+ERRMLAST)); // complain
s = UTIL_Key_Build(ptr,
&var->key[var->slen]); // get one subscript
if ((s + var->slen) > 255) // check how big
return (-(ERRZ2+ERRMLAST)); // complain on error
var->slen = s + var->slen; // add it in
}
if (type == TYPVARGBLUCIENV) // need vol?
{ ptr = (cstring *) astk[asp-subs-1]; // point at the string
s = getvol(ptr); // get volume
if (s < 0) return s; // die on error
var->volset = (u_char) s; // save the value
}
if ((type == TYPVARGBLUCI) ||
(type == TYPVARGBLUCIENV)) // need uci?
{ ptr = (cstring *)
astk[asp-subs-1-(type == TYPVARGBLUCIENV)]; // point at the string
s = getuci(ptr, var->volset); // get uci
if (s < 0) return s; // die on error
var->uci = (u_char) s; // save the value
}
if (type == TYPVARIND) asp--; // fixup asp for return
return asp - subs
- (type == TYPVARGBLUCI)
- ((type == TYPVARGBLUCIENV) * 2); // all done
}
short Dstack2x(u_char *ret_buffer, int level, cstring *code, int job)
{ int arg2 = 0; // arg 2 1 = ECODE
// 2 = MCODE
// 3 = PLACE
var_u *rounam; // routine name
int line; // line number
int i; // a handy int
u_char *p; // a handy pointer
mvar *var; // for ^$R()
u_char temp[3*MAX_NAME_BYTES]; // ditto
cstring *cptr; // ditto
short s; // ditto
ret_buffer[0] = '\0'; // null terminate
if (level < 0) return 0; // junk
i = systab->jobtab[job].cur_do; // default
if (systab->jobtab[job].error_frame > systab->jobtab[job].cur_do)
i = systab->jobtab[job].error_frame; // ensure we have the error bit
if (level > i) return 0; // nothing there
if (strncasecmp((const char *) code->buf, "ecode\0", 6) == 0) arg2 = 1;
else if (strncasecmp((const char *) code->buf, "mcode\0", 6) == 0) arg2 = 2;
else if (strncasecmp((const char *) code->buf, "place\0", 6) == 0) arg2 = 3;
else return (-(ERRZ50+ERRMLAST)); // junk
if (arg2 == 1) // "ECODE"
{ ret_buffer[0] = '\0'; // assume nothing
if (job != (partab.jobtab - systab->jobtab)) return (0); // can't find
var = (mvar *) ret_buffer; // use same space for mvar
X_set("$ECODE\0\0", &var->name.var_cu[0], 8);// copy in $ECODE
var->volset = 0;
var->uci = UCI_IS_LOCALVAR;
cptr = (cstring *) temp; // some spare space
cptr->len = itocstring(cptr->buf, level); // setup for subscript
var->slen = UTIL_Key_Build(cptr, &var->key[0]);
s = ST_Get(var, ret_buffer); // get and return
if (s == -ERRM6) s = 0; // allow for not there
return s;
}
if ((level == systab->jobtab[job].error_frame) &&
(level)) level = STM1_FRAME; // err frame adjust
if ((((systab->jobtab[job].dostk[level].type & 127) == TYPE_XECUTE) ||
((systab->jobtab[job].dostk[level].type & 127) == TYPE_RUN) ||
((systab->jobtab[job].dostk[level].type & 127) == TYPE_JOB)) &&
//(systab->jobtab[job].dostk[level].rounam.var_qu == 0))
(X_Empty(systab->jobtab[job].dostk[level].rounam.var_xu)))
{ if (arg2 == 2) // "MCODE"
{ ret_buffer[0] = '\0'; // JIC
if (systab->jobtab[job].cur_do < level) return 0; // no can do
if (job != (partab.jobtab - systab->jobtab)) return (0); // can't find
p = (u_char *)systab->jobtab[job].dostk[level].routine;
if (p == NULL) return 0; // nothing there
for (i = 0; ((ret_buffer[i] = p[i])); i++); // copy it
return i; // return the count
}
return mcopy((u_char *) "XECUTE", ret_buffer, 6); // "PLACE"
}
rounam = &(systab->jobtab[job].dostk[level].rounam); // point at routine name
line = systab->jobtab[job].dostk[level].line_num; // get line number
if (arg2 == 2) // "MCODE"
{ var = (mvar *) ret_buffer; // use same space for mvar
X_set("$ROUTINE", &var->name.var_cu[0], 8); // copy in $ROUTINE
var->volset = systab->jobtab[job].rvol; // vol number
var->uci = systab->jobtab[job].ruci; // uci number
if (rounam->var_cu[0] == '%') var->uci = 1; // check for a percent rou
cptr = (cstring *) temp; // some spare space
for (i = 0; i < MAX_NAME_BYTES; i++) // copy name
{ if (rounam->var_cu[i] == 0) break; // quit when done
cptr->buf[i] = rounam->var_cu[i]; // copy
}
cptr->buf[i] = '\0'; // null terminate
cptr->len = i; // save the length
s = UTIL_Key_Build(cptr, &var->key[0]); // make a key from it
if (s < 0) return s; // die on error
var->slen = (u_char) s; // save the length
cptr->len = itocstring(cptr->buf, line); // make a string from int
s = UTIL_Key_Build(cptr, &var->key[var->slen]); // make a key from it
if (s < 0) return s; // die on error
var->slen = (u_char) s + var->slen; // save the length
s = Dget1(ret_buffer, var); // get data
if (s < 0) s = 0; // ignore errors
ret_buffer[s] = '\0'; // null terminate
return s; // and return
}
i = 0; // the start
ret_buffer[i++] = '+'; // add plus
i = i + itocstring(&ret_buffer[i], line); // add the line number
ret_buffer[i++] = '^'; // the name indicator
for (arg2 = 0; arg2 < MAX_NAME_BYTES; arg2++) // copy name
if ((ret_buffer[i++] = rounam->var_cu[arg2]) == 0) break;
if (ret_buffer[i-1] == '\0') i--; // back up over null
ret_buffer[i] = '\0'; // null terminate
return i; // return length
}
// Set data into $ECODE
// Returns 0 if no previous error at this level
short Set_Error(int err, cstring *user, cstring *space)
{ short t; // for function calls
int j; // a handy int
int flag; // to remember
mvar *var; // a handy mvar
cstring *tmp; // spare cstring ptr
char temp[3*MAX_NAME_BYTES]; // and some space
var = &partab.src_var; // a spare mvar
var->slen = 0; // no subs
// note - the uci and volset were setup by the caller
X_set("$ECODE\0\0", &var->name.var_cu[0], 8); // get the name
t = ST_Get(var, space->buf); // get it
if (t < 0) t = 0; // ignore undefined
flag = t; // remember if some there
if (t < MAX_ECODE) // if not too big
{ if ((t == 0) || (space->buf[t-1] != ','))
space->buf[t++] = ','; // for new $EC
j = -err; // copy the error (-ve)
if (err == USRERR) // was it a SET $EC
{ bcopy(user->buf, &space->buf[t], user->len); // copy the error
t += user->len; // add the length
}
else // not user error
{ if (j > ERRMLAST) // implementation error?
{ space->buf[t++] = 'Z'; // yes, Z type
j -= ERRMLAST; // subtract it
}
else
space->buf[t++] = 'M'; // MDC error
t += itocstring(&space->buf[t], j); // convert the number
} // end 'not user error'
space->buf[t++] = ','; // trailing comma
space->buf[t] = '\0'; // null terminate
space->len = t;
t = ST_Set(var, space); // set it
tmp = (cstring *) temp; // temp space
tmp->len = itocstring(tmp->buf, partab.jobtab->cur_do);
var->slen = UTIL_Key_Build(tmp, var->key);
if (flag) // if not first one
{ t = ST_Get(var, space->buf); // get it
if (t < 0) t = 0; // ignore undefined
flag = t; // remember for the return
if ((t == 0) || (space->buf[t-1] != ','))
space->buf[t++] = ','; // for new $EC
j = -err; // copy the error (-ve)
if (err == USRERR) // was it a SET $EC
{ bcopy(user->buf, &space->buf[t], user->len); // copy the error
t += user->len; // add the length
}
else // not user error
{ if (j > ERRMLAST) // implementation error?
{ space->buf[t++] = 'Z'; // yes, Z type
j -= ERRMLAST; // subtract it
}
else
space->buf[t++] = 'M'; // MDC error
t += itocstring(&space->buf[t], j); // convert the number
}
space->buf[t++] = ','; // trailing comma
space->buf[t] = '\0'; // null terminate
space->len = t;
}
t = ST_Set(var, space); // set it
} // end "TOO BIG" test
return (short) flag; // done
}
