//*********************************************************************** // $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 }