int f_zprevious(oprtype *a, opctype op) { triple *oldchain, *r; save_se save_state; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); switch (TREF(window_token)) { case TK_IDENT: if (TK_LPAREN != TREF(director_token)) { r->opcode = OC_FNLVPRVNAME; r->operand[0] = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len); ins_triple(r); advancewindow(); break; } if (!lvn(&(r->operand[0]), OC_SRCHINDX, r)) return FALSE; ins_triple(r); break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; r->opcode = OC_ZPREVIOUS; ins_triple(r); break; case TK_ATSIGN: if (SHIFT_SIDE_EFFECTS) { START_GVBIND_CHAIN(&save_state, oldchain); if (!indirection(&(r->operand[0]))) { setcurtchain(oldchain); return FALSE; } r->operand[1] = put_ilit((mint)indir_fnzprevious); ins_triple(r); PLACE_GVBIND_CHAIN(&save_state, oldchain); } else { if (!indirection(&(r->operand[0]))) return FALSE; r->operand[1] = put_ilit((mint)indir_fnzprevious); ins_triple(r); } r->opcode = OC_INDFUN; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } *a = put_tref(r); return TRUE; }
int f_data(oprtype *a, opctype op) { triple *oldchain, *r, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; assert(OC_FNDATA == op || OC_FNZDATA == op); r = maketriple(op); switch (TREF(window_token)) { case TK_IDENT: if (!lvn(&(r->operand[0]), OC_SRCHINDX, 0)) return FALSE; ins_triple(r); break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; r->opcode = OC_GVDATA; ins_triple(r); 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 (!indirection(&(r->operand[0]))) { setcurtchain(oldchain); return FALSE; } r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata)); ins_triple(r); 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 { if (!indirection(&(r->operand[0]))) return FALSE; r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata)); ins_triple(r); } r->opcode = OC_INDFUN; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } *a = put_tref(r); return TRUE; }
int m_zwithdraw(void) { oprtype tmparg; triple *ref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; switch (TREF(window_token)) { case TK_IDENT: if (!lvn(&tmparg,OC_SRCHINDX,0)) return FALSE; ref = newtriple(OC_LVZWITHDRAW); ref->operand[0] = tmparg; break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; ref = newtriple(OC_GVZWITHDRAW); break; case TK_ATSIGN: if (!indirection(&tmparg)) return FALSE; ref = maketriple(OC_COMMARG); ref->operand[0] = tmparg; ref->operand[1] = put_ilit((mint) indir_zwithdraw); ins_triple(ref); return TRUE; default: stx_error(ERR_VAREXPECTED); return FALSE; } return TRUE; }
int m_ztrigger(void) { # ifdef GTM_TRIGGER oprtype tmparg; triple *ref; error_def(ERR_GBLEXPECTED); switch (window_token) { case TK_CIRCUMFLEX: if (!gvn()) return FALSE; ref = newtriple(OC_ZTRIGGER); break; case TK_ATSIGN: if (!indirection(&tmparg)) return FALSE; ref = maketriple(OC_COMMARG); ref->operand[0] = tmparg; ref->operand[1] = put_ilit((mint)indir_ztrigger); ins_triple(ref); return TRUE; default: stx_error(ERR_GBLEXPECTED); return FALSE; } return TRUE; # else return FALSE; # endif }
int f_get1(oprtype *a, opctype op) { triple *oldchain, *r; save_se save_state; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(OC_NOOP); /* We'll fill in the opcode later, when we figure out what it is */ switch (TREF(window_token)) { case TK_IDENT: r->opcode = OC_FNGET1; if (!lvn(&r->operand[0], OC_SRCHINDX, 0)) return FALSE; break; case TK_CIRCUMFLEX: r->opcode = OC_FNGVGET1; if (!gvn()) return FALSE; break; case TK_ATSIGN: r->opcode = OC_INDFUN; r->operand[1] = put_ilit((mint)indir_get); if (SHIFT_SIDE_EFFECTS) { /* with short-circuited booleans move indirect processing to expr_start */ START_GVBIND_CHAIN(&save_state, oldchain); if (!indirection(&r->operand[0])) { setcurtchain(oldchain); return FALSE; } ins_triple(r); PLACE_GVBIND_CHAIN(&save_state, oldchain); *a = put_tref(r); return TRUE; } if (!indirection(&(r->operand[0]))) return FALSE; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } ins_triple(r); *a = put_tref(r); return TRUE; }
void DataStruct::print( QString& out, const QString& indent, const QString& newitem, int level, int maxElemSize) const { if (atomic()) { out.append("'"); if (maxElemSize >= 0) { out.append( shortenDebugMessageArgument( value().toString(), maxElemSize)); } else { out.append( value().toString()); } out.append("'"); } else if (array()) { int ii = 1; for (; ii<=m_size; ++ii) { if (ii>1) out.append( ", "); m_data.ref[ ii].print( out, indent, newitem, level+1, maxElemSize); } } else if (indirection()) { // ... unexpanded indirection is ignored } else if (m_description) { DataStructDescription::const_iterator di = m_description->begin(), de = m_description->end(); DataStruct::const_iterator ei = structbegin(); for (int idx=0; di != de; ++di,++ei) { if (ei->initialized()) { if (idx++) { out.append( ";"); print_newitem( out, indent, newitem, level); } out.append( di->name); if (di->array()) out.append( "[]"); if (di->attribute()) { out.append( "="); out.append( ei->toString( maxElemSize)); } else { out.append( "{"); ei->print( out, indent, newitem, level+1, maxElemSize); out.append( "}"); } } } } }
int f_name(oprtype *a, opctype op) { boolean_t gbl; oprtype *depth; short int column; triple *r, *s; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); gbl = FALSE; switch (TREF(window_token)) { case TK_CIRCUMFLEX: gbl = TRUE; advancewindow(); /* caution fall through */ case TK_IDENT: if (!name_glvn(gbl, &r->operand[1])) return FALSE; depth = &r->operand[0]; break; case TK_ATSIGN: r->opcode = OC_INDFNNAME2; /* chomps extra subscripts of resulting string */ s = maketriple(OC_INDFNNAME); if (!indirection(&(s->operand[0]))) return FALSE; s->operand[1] = put_ilit(MAX_LVSUBSCRIPTS + 1); /* first, get all the subscripts. r will chomp them */ coerce(&s->operand[1], OCT_MVAL); ins_triple(s); depth = &r->operand[0]; r->operand[1] = put_tref(s); break; default: stx_error(ERR_VAREXPECTED); return FALSE; } /* allow for optional default value */ if (TK_COMMA != TREF(window_token)) { *depth = put_ilit(MAX_LVSUBSCRIPTS + 1); /* default to maximum number of subscripts allowed by law */ /* ideally this should be MAX(MAX_LVSUBSCRIPTS, MAX_GVSUBSCRIPTS) but they are the same so take the easy path */ assert(MAX_LVSUBSCRIPTS == MAX_GVSUBSCRIPTS); /* add assert to ensure our assumption is valid */ } else { DISABLE_SIDE_EFFECT_AT_DEPTH; /* doing this here let's us know specifically if direction had SE threat */ advancewindow(); column = source_column; if (EXPR_FAIL == expr(depth, MUMPS_STR)) return FALSE; if (!run_time && (OC_INDFNNAME2 == r->opcode) && (SE_WARN == TREF(side_effect_handling))) ISSUE_SIDEEFFECTEVAL_WARNING(column - 1); } coerce(depth, OCT_MVAL); ins_triple(r); *a = put_tref(r); return TRUE; }
void op_indrzshow(mval *s1,mval *s2) { mstr object; bool rval; oprtype v; triple *src, *r, *outtype, *lvar; error_def(ERR_VAREXPECTED); error_def(ERR_INDMAXNEST); comp_init(&s2->str); src = maketriple(OC_IGETSRC); ins_triple(src); switch(window_token) { case TK_CIRCUMFLEX: if (rval = gvn()) { r = maketriple(OC_ZSHOW); outtype = newtriple(OC_PARAMETER); r->operand[1] = put_tref(outtype); r->operand[0] = put_tref(src); outtype->operand[0] = put_ilit(ZSHOW_GLOBAL); ins_triple(r); } break; case TK_IDENT: if (rval = lvn(&v, OC_PUTINDX, 0)) { r = maketriple(OC_ZSHOWLOC); outtype = newtriple(OC_PARAMETER); r->operand[1] = put_tref(outtype); r->operand[0] = put_tref(src); lvar = newtriple(OC_PARAMETER); outtype->operand[1] = put_tref(lvar); lvar->operand[0] = v; outtype->operand[0] = put_ilit(ZSHOW_LOCAL); ins_triple(r); } break; case TK_ATSIGN: if (rval = indirection(&v)) { r = newtriple(OC_INDRZSHOW); r->operand[0] = put_tref(src); r->operand[1] = v; } break; default: stx_error(ERR_VAREXPECTED); break; } if (comp_fini(rval, &object, OC_RET, 0, s2->str.len)) { cache_put(indir_zshow, &s2->str, &object); *ind_source_sp++ = s1; if (ind_source_sp >= ind_source_top) rts_error(VARLSTCNT(1) ERR_INDMAXNEST); comp_indr(&object); } return; }
void op_indlvarg(mval *v, mval *dst) { bool rval; mstr *obj, object; oprtype x; triple *ref; icode_str indir_src; error_def(ERR_INDMAXNEST); error_def(ERR_VAREXPECTED); MV_FORCE_STR(v); if (v->str.len < 1) rts_error(VARLSTCNT(1) ERR_VAREXPECTED); if (valid_mname(&v->str)) { *dst = *v; dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */ return; } if (*v->str.addr == '@') { indir_src.str = v->str; indir_src.code = indir_lvarg; if (NULL == (obj = cache_get(&indir_src))) { object.addr = v->str.addr; object.len = v->str.len; comp_init(&object); if (rval = indirection(&x)) { ref = newtriple(OC_INDLVARG); ref->operand[0] = x; x = put_tref(ref); } if (comp_fini(rval, &object, OC_IRETMVAL, &x, object.len)) { indir_src.str.addr = v->str.addr; cache_put(&indir_src, &object); *ind_result_sp++ = dst; if (ind_result_sp >= ind_result_top) rts_error(VARLSTCNT(1) ERR_INDMAXNEST); comp_indr(&object); return; } } else { *ind_result_sp++ = dst; if (ind_result_sp >= ind_result_top) rts_error(VARLSTCNT(1) ERR_INDMAXNEST); comp_indr(obj); return; } } rts_error(VARLSTCNT(1) ERR_VAREXPECTED); }
void op_indlvarg(mval *v, mval *dst) { icode_str indir_src; int rval; mstr *obj, object; oprtype x; triple *ref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; if (TREF(ind_result_sp) >= TREF(ind_result_top)) rts_error(VARLSTCNT(1) ERR_INDMAXNEST); /* mdbcondition_handler resets ind_result_sp */ MV_FORCE_STR(v); if (v->str.len < 1) rts_error(VARLSTCNT(1) ERR_VAREXPECTED); if (valid_mname(&v->str)) { *dst = *v; dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */ return; } if (*v->str.addr != '@') rts_error(VARLSTCNT(1) ERR_VAREXPECTED); indir_src.str = v->str; indir_src.code = indir_lvarg; if (NULL == (obj = cache_get(&indir_src))) { obj = &object; obj->addr = v->str.addr; obj->len = v->str.len; comp_init(obj); if (EXPR_FAIL != (rval = indirection(&x))) /* NOTE assignment */ { ref = newtriple(OC_INDLVARG); ref->operand[0] = x; x = put_tref(ref); } if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &x, obj->len)) return; indir_src.str.addr = v->str.addr; cache_put(&indir_src, obj); /* Fall into code activation below */ } *(TREF(ind_result_sp))++ = dst; /* Where to store return value */ comp_indr(obj); return; }
void KdCluster::leafWriteGroup(KdTreeNode *node, const BoundingBox & box) { const unsigned num = node->getNumPrims(); if(num < 1) return; m_groupGeometries[m_currentGroup] = new GeometryArray; GeometryArray * curGrp = m_groupGeometries[m_currentGroup]; curGrp->create(num); unsigned start = node->getPrimStart(); sdb::VectorArray<Primitive> &indir = indirection(); //sdb::VectorArray<Primitive> &prims = primitives(); int igeom, icomponent; unsigned igroup = 0; for(unsigned i = 0; i < num; i++) { //unsigned *iprim = indir[start + i]; //Primitive * prim = prims.get(*iprim); Primitive * prim = indir[start + i]; prim->getGeometryComponent(igeom, icomponent); Geometry * geo = m_stream.geometry(igeom); if(geo->type() == TGeometryArray) { GeometryArray * ga = (GeometryArray *)geo; Geometry * comp = ga->geometry(icomponent); BoundingBox comb = ga->calculateBBox(icomponent); // do not add straddling geo if(comb.getMax(0) <= box.getMax(0) && comb.getMax(1) <= box.getMax(1) && comb.getMax(2) <= box.getMax(2)) { curGrp->setGeometry(comp, igroup); igroup++; } } else { std::cout<<" grouping only works with geometry arry."; } //indir.next(); } curGrp->setNumGeometries(igroup); m_nodeGroupInd[node] = m_currentGroup; m_currentGroup++; }
int m_zdeallocate(void) { oprtype indopr; triple *ref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; newtriple(OC_LKINIT); switch(TREF(window_token)) { case TK_EOL: case TK_SPACE: break; case TK_ATSIGN: if (!indirection(&indopr)) return FALSE; ref = newtriple(OC_COMMARG); ref->operand[0] = indopr; ref->operand[1] = put_ilit((mint)indir_zdeallocate); return TRUE; break; case TK_LPAREN: do { advancewindow(); if (EXPR_FAIL == nref()) return FALSE; } while (TK_COMMA == TREF(window_token)); if (TK_RPAREN != TREF(window_token)) { stx_error(ERR_RPARENMISSING); return FALSE; } advancewindow(); break; default: if (EXPR_FAIL == nref()) return FALSE; break; } ref = newtriple(OC_ZDEALLOCATE); ref->operand[0] = put_ilit(NO_M_TIMEOUT); return EXPR_GOOD; }
void op_indlvadr(mval *target) { error_def(ERR_VAREXPECTED); bool rval; mstr object, *obj; oprtype v; triple *s; MV_FORCE_STR(target); if (!(obj = cache_get(indir_lvadr, &target->str))) { comp_init(&target->str); switch (window_token) { case TK_IDENT: rval = lvn(&v, OC_PUTINDX, 0); if (comp_fini(rval, &object, OC_IRETMVAD, &v, target->str.len)) { cache_put(indir_lvadr, &target->str, &object); comp_indr(&object); } break; case TK_ATSIGN: if (rval = indirection(&v)) { s = newtriple(OC_INDLVADR); s->operand[0] = v; v = put_tref(s); if (comp_fini(rval, &object, OC_IRETMVAD, &v, target->str.len)) { cache_put(indir_lvadr, &target->str, &object); comp_indr(&object); } } break; default: stx_error(ERR_VAREXPECTED); break; } } else { comp_indr(obj); } }
void op_inddevparms(mval *devpsrc, int4 ok_iop_parms, mval *devpiopl) { int rval; icode_str indir_src; mstr *obj, object; oprtype devpopr, plist, getdst; triple *indref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; MV_FORCE_STR(devpsrc); indir_src.str = devpsrc->str; indir_src.code = indir_devparms; if (NULL == (obj = cache_get(&indir_src))) /* NOTE assignment */ { /* No cached version, compile it now */ obj = &object; comp_init(&devpsrc->str, &getdst); if (TK_ATSIGN == TREF(window_token)) { /* For the indirection-obsessive */ if (EXPR_FAIL != (rval = indirection(&devpopr))) /* NOTE assignment */ { indref = newtriple(OC_INDDEVPARMS); indref->operand[0] = devpopr; indref->operand[1] = put_ilit(ok_iop_parms); plist = put_tref(indref); } } else /* We have the parm string to process now */ rval = deviceparameters(&plist, ok_iop_parms); if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &plist, &getdst, devpsrc->str.len)) return; indir_src.str.addr = devpsrc->str.addr; cache_put(&indir_src, obj); /* Fall into code activation below */ } TREF(ind_result) = devpiopl; /* Where to store return value */ comp_indr(obj); return; }
bool KdIntersection::leafIntersectBox(KdTreeNode *node, const BoundingBox & box) { const unsigned num = node->getNumPrims(); if(num < 1) return false; if(!box.intersect(m_testBox)) return false; unsigned start = node->getPrimStart(); IndexArray &indir = indirection(); PrimitiveArray &prims = primitives(); indir.setIndex(start); for(unsigned i = 0; i < num; i++) { unsigned *iprim = indir.asIndex(); Primitive * prim = prims.asPrimitive(*iprim); Geometry * geo = prim->getGeometry(); unsigned icomponent = prim->getComponentIndex(); if(geo->intersectBox(icomponent, m_testBox)) return true; indir.next(); } return false; }
int m_merge(void) { int type; boolean_t used_glvn_slot; mval mv; opctype put_oc; oprtype mopr, control_slot; triple *obp, *ref, *restart, *s1, *sub, tmpchain; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; used_glvn_slot = FALSE; sub = NULL; restart = newtriple(OC_RESTARTPC); /* Here is where a restart should pick up */ dqinit(&tmpchain, exorder); /* Left Hand Side of EQUAL sign */ switch (TREF(window_token)) { case TK_IDENT: if (!lvn(&mopr, OC_PUTINDX, 0)) return FALSE; if (OC_PUTINDX == mopr.oprval.tref->opcode) { /* we insert left hand side argument into tmpchain. */ sub = mopr.oprval.tref; put_oc = OC_PUTINDX; dqdel(mopr.oprval.tref, exorder); dqins(tmpchain.exorder.bl, exorder, mopr.oprval.tref); } ref = maketriple(OC_MERGE_LVARG); ref->operand[0] = put_ilit(MARG1_LCL); ref->operand[1] = mopr; dqins(tmpchain.exorder.bl, exorder, ref); break; case TK_CIRCUMFLEX: s1 = (TREF(curtchain))->exorder.bl; if (!gvn()) return FALSE; assert(OC_GVRECTARG != (TREF(curtchain))->opcode); /* we count on gvn not having been shifted */ for (sub = (TREF(curtchain))->exorder.bl; sub != s1; sub = sub->exorder.bl) { put_oc = sub->opcode; if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc) break; } assert((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc) || (OC_GVEXTNAM == put_oc)); /* we insert left hand side argument into tmpchain. */ dqdel(sub, exorder); dqins(tmpchain.exorder.bl ,exorder, sub); ref = maketriple(OC_MERGE_GVARG); ref->operand[0] = put_ilit(MARG1_GBL); dqins(tmpchain.exorder.bl, exorder, ref); break; case TK_ATSIGN: if (!indirection(&mopr)) return FALSE; if (TK_EQUAL != TREF(window_token)) { ref = newtriple(OC_COMMARG); ref->operand[0] = mopr; ref->operand[1] = put_ilit((mint) indir_merge); return TRUE; } type = MARG1_LCL | MARG1_GBL; memset(&mv, 0, SIZEOF(mval)); /* Initialize so unused fields don't cause object hash differences */ MV_FORCE_MVAL(&mv, type); MV_FORCE_STRD(&mv); if (TREF(side_effect_handling)) { /* save and restore the variable lookup for true left-to-right evaluation */ used_glvn_slot = TRUE; INSERT_INDSAVGLVN(control_slot, mopr, ANY_SLOT, 0); /* 0 flag to defer global reference */ ref = maketriple(OC_INDMERGE2); ref->operand[0] = control_slot; } else { /* quick and dirty old way */ ref = maketriple(OC_INDMERGE); ref->operand[0] = put_lit(&mv); ref->operand[1] = mopr; } /* we insert left hand side argument into tmpchain. */ dqins(tmpchain.exorder.bl, exorder, ref); break; default: stx_error(ERR_VAREXPECTED); return FALSE; } if (TREF(window_token) != TK_EQUAL) { stx_error(ERR_EQUAL); return FALSE; } advancewindow(); /* Right Hand Side of EQUAL sign */ TREF(temp_subs) = FALSE; switch (TREF(window_token)) { case TK_IDENT: if (!lvn(&mopr, OC_M_SRCHINDX, 0)) return FALSE; ref = newtriple(OC_MERGE_LVARG); ref->operand[0] = put_ilit(MARG2_LCL); ref->operand[1] = mopr; break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; ref = newtriple(OC_MERGE_GVARG); ref->operand[0] = put_ilit(MARG2_GBL); break; case TK_ATSIGN: TREF(temp_subs) = TRUE; if (!indirection(&mopr)) { stx_error(ERR_VAREXPECTED); return FALSE; } type = MARG2_LCL | MARG2_GBL; memset(&mv, 0, SIZEOF(mval)); /* Initialize so unused fields don't cause object hash differences */ MV_FORCE_MVAL(&mv, type); MV_FORCE_STRD(&mv); ref = maketriple(OC_INDMERGE); ref->operand[0] = put_lit(&mv); ref->operand[1] = mopr; ins_triple(ref); break; default: stx_error(ERR_VAREXPECTED); return FALSE; } /* * Make sure that during runtime right hand side argument is processed first. * This is specially important if global naked variable is used . */ obp = (TREF(curtchain))->exorder.bl; dqadd(obp, &tmpchain, exorder); if (TREF(temp_subs) && TREF(side_effect_handling) && sub) create_temporaries(sub, put_oc); TREF(temp_subs) = FALSE; if (used_glvn_slot) { ref = newtriple(OC_GLVNPOP); ref->operand[0] = control_slot; } ref = newtriple(OC_MERGE); return TRUE; }
int m_for(void) { unsigned int arg_cnt, arg_index, for_stack_level; oprtype arg_eval_addr[MAX_FORARGS], increment[MAX_FORARGS], terminate[MAX_FORARGS], arg_next_addr, arg_value, dummy, control_variable, *iteration_start_addr, iteration_start_addr_indr, *not_even_once_addr; triple *eval_next_addr[MAX_FORARGS], *control_ref, *forchk1opc, forpos_in_chain, *init_ref, *ref, *step_ref, *term_ref, *var_ref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; forpos_in_chain = TREF(pos_in_chain); FOR_PUSH(); if (TK_SPACE == TREF(window_token)) { /* "argumentless" form */ FOR_END_OF_SCOPE(1, dummy); ref = newtriple(OC_FORCHK1); if (!linetail()) { TREF(pos_in_chain) = forpos_in_chain; assert(TREF(source_error_found)); stx_error(TREF(source_error_found)); FOR_POP(BLOWN_FOR); return FALSE; } SAVE_FOR_OVER_ADDR(); /* stash address of next op in the for_stack array */ newtriple(OC_JMP)->operand[0] = put_tjmp(ref); /* transfer back to just before the begining of the body */ FOR_POP(GOOD_FOR); /* and pop the array */ return TRUE; } for_stack_level = (TREF(for_stack_ptr) - TADR(for_stack)); init_ref = newtriple(OC_FORNESTLVL); init_ref->operand[0] = put_ilit(for_stack_level); if (TK_ATSIGN == TREF(window_token)) { if (!indirection(&control_variable)) { FOR_POP(BLOWN_FOR); return FALSE; } ref = newtriple(OC_INDLVADR); ref->operand[0] = control_variable; control_variable = put_tref(ref); control_ref = NULL; } else { /* The following relies on the fact that lvn() always generates an OC_VAR triple first */ control_ref = (TREF(curtchain))->exorder.bl; if (!lvn(&control_variable, OC_SAVPUTINDX, NULL)) { FOR_POP(BLOWN_FOR); return FALSE; } assert(OC_VAR == control_ref->exorder.fl->opcode); assert(MVAR_REF == control_ref->exorder.fl->operand[0].oprclass); } if (TK_EQUAL != TREF(window_token)) { stx_error(ERR_EQUAL); FOR_POP(BLOWN_FOR); return FALSE; } newtriple(OC_PASSTHRU)->operand[0] = control_variable; /* make sure optimizer doesn't ditch control_variable */ FOR_END_OF_SCOPE(1, dummy); assert((0 < for_stack_level) && (MAX_FOR_STACK >= for_stack_level)); if ((OC_SAVPUTINDX == control_variable.oprval.tref->opcode) || (OC_INDLVADR == control_variable.oprval.tref->opcode)) TAREF1(for_temps, for_stack_level) = TRUE_WITH_INDX; /* most uses treat this as a boolean, but some need more */ else init_ref->opcode = OC_NOOP; iteration_start_addr = (oprtype *)mcalloc(SIZEOF(oprtype)); iteration_start_addr_indr = put_indr(iteration_start_addr); arg_next_addr.oprclass = NOCLASS; not_even_once_addr = NULL; /* used to skip processing where the initial control exceeds the termination */ for (arg_cnt = 0; ; ++arg_cnt) { if (MAX_FORARGS <= arg_cnt) { stx_error(ERR_MAXFORARGS); FOR_POP(BLOWN_FOR); return FALSE; } assert((TK_COMMA == TREF(window_token)) || (TK_EQUAL == TREF(window_token))); advancewindow(); tnxtarg(&arg_eval_addr[arg_cnt]); /* put location of this arg eval in arg_eval_addr array */ if (NULL != not_even_once_addr) { *not_even_once_addr = arg_eval_addr[arg_cnt]; not_even_once_addr = NULL; } if (EXPR_FAIL == expr(&arg_value, MUMPS_EXPR)) /* starting (possibly only) value */ { FOR_POP(BLOWN_FOR); return FALSE; } assert(TRIP_REF == arg_value.oprclass); if (TK_COLON != TREF(window_token)) { /* list point value? */ increment[arg_cnt].oprclass = terminate[arg_cnt].oprclass = 0; DEAL_WITH_DANGER(for_stack_level, control_variable, arg_value); } else { /* stepping value */ init_ref = newtriple(OC_STOTEMP); /* tuck it in a temp undisturbed by coming evals */ init_ref->operand[0] = arg_value; newtriple(OC_CONUM)->operand[0] = put_tref(init_ref); /* make start numeric */ advancewindow(); /* past the first colon */ var_ref = (TREF(curtchain))->exorder.bl; if (EXPR_FAIL == expr(&increment[arg_cnt], MUMPS_EXPR)) /* pick up step */ { FOR_POP(BLOWN_FOR); return FALSE; } assert(TRIP_REF == increment[arg_cnt].oprclass); ref = increment[arg_cnt].oprval.tref; if (OC_LIT != var_ref->exorder.fl->opcode) { if (!TAREF1(for_temps, for_stack_level)) TAREF1(for_temps, for_stack_level) = TRUE; if (OC_VAR == var_ref->exorder.fl->opcode) { /* The above relies on lvn() always generating an OC_VAR triple first - asserted earlier */ step_ref = newtriple(OC_STOTEMP); step_ref->operand[0] = put_tref(ref); increment[arg_cnt] = put_tref(step_ref); } } if (TK_COLON != TREF(window_token)) { DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref)); terminate[arg_cnt].oprclass = 0; /* no termination on iteration for this arg */ } else { advancewindow(); /* past the second colon */ var_ref = (TREF(curtchain))->exorder.bl; if (EXPR_FAIL == expr(&terminate[arg_cnt], MUMPS_EXPR)) /* termination control value */ { FOR_POP(BLOWN_FOR); return FALSE; } assert(TRIP_REF == terminate[arg_cnt].oprclass); ref = terminate[arg_cnt].oprval.tref; if (OC_LIT != ref->opcode) { if (!TAREF1(for_temps, for_stack_level)) TAREF1(for_temps, for_stack_level) = TRUE; if (OC_VAR == var_ref->exorder.fl->opcode) { /* The above relies on lvn() always generating an OC_VAR triple first */ term_ref = newtriple(OC_STOTEMP); term_ref->operand[0] = put_tref(ref); terminate[arg_cnt] = put_tref(term_ref); } } DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref)); term_ref = newtriple(OC_PARAMETER); term_ref->operand[0] = terminate[arg_cnt]; step_ref = newtriple(OC_PARAMETER); step_ref->operand[0] = increment[arg_cnt]; step_ref->operand[1] = put_tref(term_ref); ref = newtriple(OC_FORINIT); ref->operand[0] = control_variable; ref->operand[1] = put_tref(step_ref); not_even_once_addr = newtriple(OC_JMPGTR)->operand; } } if ((0 < arg_cnt) || (TK_COMMA == TREF(window_token))) { if (!TAREF1(for_temps, for_stack_level)) TAREF1(for_temps, for_stack_level) = TRUE; if (NOCLASS == arg_next_addr.oprclass) arg_next_addr = put_tref(newtriple(OC_CDADDR)); (eval_next_addr[arg_cnt] = newtriple(OC_LDADDR))->destination = arg_next_addr; } if (TK_COMMA != TREF(window_token)) break; newtriple(OC_JMP)->operand[0] = iteration_start_addr_indr; } if (not_even_once_addr) FOR_END_OF_SCOPE(1, *not_even_once_addr); /* 1 means down a level */ forchk1opc = newtriple(OC_FORCHK1); /* FORCHK1 is a do-nothing routine used by the out-of-band mechanism */ *iteration_start_addr = put_tjmp(forchk1opc); if ((TK_EOL != TREF(window_token)) && (TK_SPACE != TREF(window_token))) { stx_error(ERR_SPOREOL); FOR_POP(BLOWN_FOR); return FALSE; } if (!linetail()) { TREF(pos_in_chain) = forpos_in_chain; assert(TREF(source_error_found)); stx_error(TREF(source_error_found)); FOR_POP(BLOWN_FOR); return FALSE; } SAVE_FOR_OVER_ADDR(); /* stash address of next op in the for_stack array */ if (0 < arg_cnt) newtriple(OC_JMPAT)->operand[0] = put_tref(eval_next_addr[0]); for (arg_index = 0; arg_index <= arg_cnt; ++arg_index) { if (0 < arg_cnt) tnxtarg(eval_next_addr[arg_index]->operand); if (TRUE_WITH_INDX == TAREF1(for_temps, for_stack_level)) { /* since it might have moved, before touching the control variable get a fix on it */ ref = newtriple(OC_RFRSHINDX); ref->operand[0] = put_ilit(for_stack_level); ref->operand[1] = put_ilit((increment[arg_index].oprclass || terminate[arg_index].oprclass) ? FALSE : TRUE); /* if increment rather than new value, rfrsh w/ srchindx else putindx */ control_variable = put_tref(ref); } else { assert(control_ref); control_variable = put_mvar(&control_ref->exorder.fl->operand[0].oprval.vref->mvname); } newtriple(OC_PASSTHRU)->operand[0] = control_variable; /* warn off optimizer */ if (terminate[arg_index].oprclass) { term_ref = newtriple(OC_PARAMETER); term_ref->operand[0] = terminate[arg_index]; step_ref = newtriple(OC_PARAMETER); step_ref->operand[0] = increment[arg_index]; step_ref->operand[1] = put_tref(term_ref); init_ref = newtriple(OC_PARAMETER); init_ref->operand[0] = control_variable; init_ref->operand[1] = put_tref(step_ref); ref = newtriple(OC_FORLOOP); /* redirects back to forchk1, which is at the beginning of new iteration */ ref->operand[0] = *iteration_start_addr; ref->operand[1] = put_tref(init_ref); } else if (increment[arg_index].oprclass) { step_ref = newtriple(OC_ADD); step_ref->operand[0] = control_variable; step_ref->operand[1] = increment[arg_index]; ref = newtriple(OC_STO); ref->operand[0] = control_variable; ref->operand[1] = put_tref(step_ref); newtriple(OC_JMP)->operand[0] = *iteration_start_addr; } if (arg_index < arg_cnt) /* go back and evaluate the next argument */ newtriple(OC_JMP)->operand[0] = arg_eval_addr[arg_index + 1]; } FOR_POP(GOOD_FOR); return TRUE; }
int f_order(oprtype *a, opctype op) { boolean_t ok, used_glvn_slot; enum order_dir direction; enum order_obj object; int4 intval; opctype gv_oc; oprtype control_slot, dir_opr, *dir_oprptr, *next_oprptr; short int column; triple *oldchain, *r, *sav_dirref, *sav_gv1, *sav_gvn, *sav_lvn, *sav_ref, *share, *triptr; triple *chain2, *obp, tmpchain2; save_se save_state; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; oldchain = sav_dirref = NULL; /* default to no direction and no shifting indirection */ used_glvn_slot = FALSE; sav_gv1 = TREF(curtchain); r = maketriple(OC_NOOP); /* We'll fill in the opcode later, when we figure out what it is */ switch (TREF(window_token)) { case TK_IDENT: if (TK_LPAREN == TREF(director_token)) { object = LOCAL; ok = lvn(&r->operand[0], OC_SRCHINDX, r); /* 2nd arg causes us to mess below with return from lvn */ } else { object = LOCAL_NAME; ok = TRUE; r->operand[0] = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len); advancewindow(); } next_oprptr = &r->operand[1]; break; case TK_CIRCUMFLEX: object = GLOBAL; ok = gvn(); sav_gvn = (TREF(curtchain))->exorder.bl; next_oprptr = &r->operand[0]; break; case TK_ATSIGN: object = INDIRECT; if (SHIFT_SIDE_EFFECTS) START_GVBIND_CHAIN(&save_state, oldchain); ok = indirection(&r->operand[0]); next_oprptr = &r->operand[1]; break; default: ok = FALSE; break; } if (!ok) { if (NULL != oldchain) setcurtchain(oldchain); stx_error(ERR_VAREXPECTED); return FALSE; } if (TK_COMMA != TREF(window_token)) direction = FORWARD; /* default direction */ else { /* two argument form: ugly logic for direction */ advancewindow(); column = source_column; dir_oprptr = (oprtype *)mcalloc(SIZEOF(oprtype)); dir_opr = put_indr(dir_oprptr); sav_ref = newtriple(OC_GVSAVTARG); DISABLE_SIDE_EFFECT_AT_DEPTH; /* doing this here let's us know specifically if direction had SE threat */ if (EXPR_FAIL == expr(dir_oprptr, MUMPS_EXPR)) { if (NULL != oldchain) setcurtchain(oldchain); return FALSE; } assert(TRIP_REF == dir_oprptr->oprclass); triptr = dir_oprptr->oprval.tref; if (OC_LIT == triptr->opcode) { /* if direction is a literal - pick it up and stop flailing about */ if (MV_IS_TRUEINT(&triptr->operand[0].oprval.mlit->v, &intval) && (1 == intval || -1 == intval)) { direction = (1 == intval) ? FORWARD : BACKWARD; sav_ref->opcode = OC_NOOP; sav_ref = NULL; } else { /* bad direction */ if (NULL != oldchain) setcurtchain(oldchain); stx_error(ERR_ORDER2); return FALSE; } } else { direction = TBD; sav_dirref = newtriple(OC_GVSAVTARG); /* $R reflects direction eval even if we revisit 1st arg */ triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(sav_ref); switch (object) { case GLOBAL: /* The direction may have had a side effect, so take copies of subscripts */ *next_oprptr = *dir_oprptr; for (; sav_gvn != sav_gv1; sav_gvn = sav_gvn->exorder.bl) { /* hunt down the gv opcode */ gv_oc = sav_gvn->opcode; if ((OC_GVNAME == gv_oc) || (OC_GVNAKED == gv_oc) || (OC_GVEXTNAM == gv_oc)) break; } assert((OC_GVNAME == gv_oc) || (OC_GVNAKED == gv_oc) || (OC_GVEXTNAM == gv_oc)); TREF(temp_subs) = TRUE; create_temporaries(sav_gvn, gv_oc); break; case LOCAL: /* Additionally need to move srchindx triple to after potential side effect */ triptr = newtriple(OC_PARAMETER); triptr->operand[0] = *next_oprptr; triptr->operand[1] = *(&dir_opr); *next_oprptr = put_tref(triptr); sav_lvn = r->operand[0].oprval.tref; assert((OC_SRCHINDX == sav_lvn->opcode) || (OC_VAR == sav_lvn->opcode)); if (OC_SRCHINDX == sav_lvn->opcode) { dqdel(sav_lvn, exorder); ins_triple(sav_lvn); TREF(temp_subs) = TRUE; create_temporaries(sav_lvn, OC_SRCHINDX); } assert(&r->operand[1] == next_oprptr); assert(TRIP_REF == next_oprptr->oprclass); assert(OC_PARAMETER == next_oprptr->oprval.tref->opcode); assert(TRIP_REF == next_oprptr->oprval.tref->operand[0].oprclass); sav_lvn = next_oprptr->oprval.tref->operand[0].oprval.tref; if ((OC_VAR == sav_lvn->opcode) || (OC_GETINDX == sav_lvn->opcode)) { /* lvn excludes the last subscript from srchindx and attaches it to the "parent" * now we find it is an lvn and needs protection too */ triptr = maketriple(OC_STOTEMP); triptr->operand[0] = put_tref(sav_lvn); dqins(sav_lvn, exorder, triptr); /* NOTE: violation of info hiding */ next_oprptr->oprval.tref->operand[0].oprval.tref = triptr; } break; case INDIRECT: /* Save and restore the variable lookup for true left-to-right evaluation */ *next_oprptr = *dir_oprptr; used_glvn_slot = TRUE; dqinit(&tmpchain2, exorder); chain2 = setcurtchain(&tmpchain2); INSERT_INDSAVGLVN(control_slot, r->operand[0], ANY_SLOT, 1); setcurtchain(chain2); obp = sav_ref->exorder.bl; /* insert before second arg */ dqadd(obp, &tmpchain2, exorder); r->operand[0] = control_slot; break; case LOCAL_NAME: /* left argument is a string - side effect can't screw it up */ *next_oprptr = *dir_oprptr; break; default: assert(FALSE); } ins_triple(r); if (used_glvn_slot) { triptr = newtriple(OC_GLVNPOP); triptr->operand[0] = control_slot; } if (SE_WARN_ON && (TREF(side_effect_base))[TREF(expr_depth)]) ISSUE_SIDEEFFECTEVAL_WARNING(column - 1); DISABLE_SIDE_EFFECT_AT_DEPTH; /* usual side effect processing doesn't work for $ORDER() */ } } if (TBD != direction) ins_triple(r); if (NULL != sav_dirref) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(sav_dirref); } r->opcode = order_opc[object][direction]; /* finally - the op code */ if (NULL != oldchain) PLACE_GVBIND_CHAIN(&save_state, oldchain); /* shift chain back to "expr_start" */ if (OC_FNLVNAME == r->opcode) *next_oprptr = put_ilit(0); /* Flag not to return aliases with no value */ if (OC_INDFUN == r->opcode) *next_oprptr = put_ilit((mint)((FORWARD == direction) ? indir_fnorder1 : indir_fnzprevious)); *a = put_tref(r); return TRUE; }
int actuallist (oprtype *opr) { triple *ref0, *ref1, *ref2, *masktrip, *counttrip; oprtype ot; int mask, parmcount; error_def (ERR_MAXACTARG); error_def (ERR_NAMEEXPECTED); error_def (ERR_COMMAORRPARENEXP); assert (window_token == TK_LPAREN); advancewindow (); masktrip = newtriple (OC_PARAMETER); mask = 0; counttrip = newtriple (OC_PARAMETER); masktrip->operand[1] = put_tref (counttrip); ref0 = counttrip; if (window_token == TK_RPAREN) parmcount = 0; else for (parmcount = 1; ; parmcount++) { if (parmcount > MAX_ACTUALS) { stx_error (ERR_MAXACTARG); return FALSE; } if (window_token == TK_PERIOD) { advancewindow (); if (window_token == TK_IDENT) { ot = put_mvar (&window_ident); mask |= (1 << parmcount - 1); advancewindow (); } else if (window_token == TK_ATSIGN) { if (!indirection(&ot)) return FALSE; ref2 = newtriple(OC_INDLVNAMADR); ref2->operand[0] = ot; ot = put_tref(ref2); mask |= (1 << parmcount - 1); } else { stx_error (ERR_NAMEEXPECTED); return FALSE; } } else if (window_token == TK_COMMA) { ref2 = newtriple(OC_NULLEXP); ot = put_tref(ref2); } else if (!expr (&ot)) return FALSE; ref1 = newtriple (OC_PARAMETER); ref0->operand[1] = put_tref (ref1); ref1->operand[0] = ot; if (window_token == TK_COMMA) { advancewindow (); if (window_token == TK_RPAREN) { ref0 = ref1; ref2 = newtriple(OC_NULLEXP); ot = put_tref(ref2); ref1 = newtriple (OC_PARAMETER); ref0->operand[1] = put_tref (ref1); ref1->operand[0] = ot; parmcount++; break; } } else if (window_token == TK_RPAREN) break; else { stx_error (ERR_COMMAORRPARENEXP); return FALSE; } ref0 = ref1; } advancewindow (); masktrip->operand[0] = put_ilit (mask); counttrip->operand[0] = put_ilit (parmcount); parmcount += 2; *opr = put_tref (masktrip); return parmcount; }
int m_merge(void) { error_def(ERR_VAREXPECTED); error_def(ERR_RPARENMISSING); error_def(ERR_EQUAL); opctype put_oc; oprtype mopr; triple *sub, *ref, *obp, *s1, *restart, tmpchain; mval mv; int type; restart = newtriple(OC_RESTARTPC); /* Here is where a restart should pick up */ dqinit(&tmpchain, exorder); /* Left Hand Side of EQUAL sign */ switch (window_token) { case TK_IDENT: if (!lvn(&mopr, OC_PUTINDX, 0)) return FALSE; if (OC_PUTINDX == mopr.oprval.tref->opcode); { /* we insert left hand side argument into tmpchain. */ dqdel(mopr.oprval.tref, exorder); dqins(tmpchain.exorder.bl, exorder, mopr.oprval.tref); } ref = maketriple(OC_MERGE_LVARG); ref->operand[0] = put_ilit(MARG1_LCL); ref->operand[1] = mopr; dqins(tmpchain.exorder.bl, exorder, ref); break; case TK_CIRCUMFLEX: s1 = curtchain->exorder.bl; if (!gvn()) return FALSE; for (sub = curtchain->exorder.bl; sub != s1; sub = sub->exorder.bl) { put_oc = sub->opcode; if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc) break; } assert(OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc); /* we insert left hand side argument into tmpchain. */ dqdel(sub, exorder); dqins(tmpchain.exorder.bl ,exorder, sub); ref = maketriple(OC_MERGE_GVARG); ref->operand[0] = put_ilit(MARG1_GBL); dqins(tmpchain.exorder.bl, exorder, ref); break; case TK_ATSIGN: if (!indirection(&mopr)) return FALSE; if (window_token != TK_EQUAL) { ref = newtriple(OC_COMMARG); ref->operand[0] = mopr; ref->operand[1] = put_ilit((mint) indir_merge); ins_triple(ref); return TRUE; } type = MARG1_LCL | MARG1_GBL; MV_FORCE_MVAL(&mv, type); MV_FORCE_STR(&mv); ref = maketriple(OC_INDMERGE); ref->operand[0] = put_lit(&mv); ref->operand[1] = mopr; /* we insert left hand side argument into tmpchain. */ dqins(tmpchain.exorder.bl, exorder, ref); break; default: stx_error(ERR_VAREXPECTED); return FALSE; } if (window_token != TK_EQUAL) { stx_error(ERR_EQUAL); return FALSE; } advancewindow(); /* Right Hand Side of EQUAL sign */ switch (window_token) { case TK_IDENT: if (!lvn(&mopr, OC_M_SRCHINDX, 0)) return FALSE; ref = newtriple(OC_MERGE_LVARG); ref->operand[0] = put_ilit(MARG2_LCL); ref->operand[1] = mopr; break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; ref = newtriple(OC_MERGE_GVARG); ref->operand[0] = put_ilit(MARG2_GBL); break; case TK_ATSIGN: if (!indirection(&mopr)) { stx_error(ERR_VAREXPECTED); return FALSE; } type = MARG2_LCL | MARG2_GBL; MV_FORCE_MVAL(&mv, type); MV_FORCE_STR(&mv); ref = maketriple(OC_INDMERGE); ref->operand[0] = put_lit(&mv); ref->operand[1] = mopr; ins_triple(ref); break; default: stx_error(ERR_VAREXPECTED); return FALSE; } /* * Make sure that during runtime right hand side argument is processed first. * This is specially important if global naked variable is used . */ obp = curtchain->exorder.bl; dqadd(obp, &tmpchain, exorder); ref = newtriple(OC_MERGE); return TRUE; }
int m_set(void) { /* Some comment on "parse_warn". It is set to TRUE whenever the parse encounters an invalid setleft target. * Note that even if "parse_warn" is TRUE, we should not return FALSE right away but need to continue the parse * until the end of the current SET command. This way any remaining commands in the current parse line will be * parsed and triples generated for them. This is necessary just in case the currently parsed invalid SET command * does not get executed at runtime (due to postconditionals etc.) * * Some comment on the need for "first_setleft_invalid". This variable is needed only in the * case we encounter an invalid-SVN/invalid-FCN/unsettable-SVN as a target of the SET. We need to evaluate the * right-hand-side of the SET command only if at least one valid setleft target is parsed before an invalid setleft * target is encountered. This is because we still need to execute the valid setlefts at runtime before triggering * a runtime error for the invalid setleft. If the first setleft target is an invalid one, then there is no need * to evaluate the right-hand-side. In fact, in this case, adding triples (corresponding to the right hand side) * to the execution chain could cause problems with emit_code later in the compilation as the destination * for the right hand side triples could now be undefined (for example a valid SVN on the left side of the * SET would have generated an OC_SVPUT triple with one of its operands holding the result of the right * hand side evaluation, but an invalid SVN on the left side which would have instead caused an OC_RTERROR triple * to have been generated leaving no triple to receive the result of the right hand side evaluation thus causing * emit_code to be confused and GTMASSERT). Therefore discard all triples generated by the right hand side in this case. * By the same reasoning, discard all triples generated by setleft targets AFTER this invalid one as well. * "first_setleft_invalid" is set to TRUE if the first setleft target is invalid and set to FALSE if the first setleft * target is valid. It is initialized to -1 before the start of the parse. */ int index, setop, delimlen; int first_val_lit, last_val_lit, nakedzalias; boolean_t first_is_lit, last_is_lit, got_lparen, delim1char, is_extract, valid_char; boolean_t alias_processing, have_lh_alias; opctype put_oc; oprtype v, delimval, firstval, lastval, *result, resptr; triple *curtargchain, *delimiter, discardcurtchain, *first, *get, *jmptrp1, *jmptrp2, *last, *obp, *put; triple *s, *s0, *s1, save_targchain, *save_curtchain, *save_curtchain1, *sub, targchain, *tmp; mint delimlit; mval *delim_mval; mvar *mvarptr; boolean_t parse_warn; /* set to TRUE in case of an invalid SVN etc. */ boolean_t curtchain_switched; /* set to TRUE if a setcurtchain was done */ int first_setleft_invalid; /* set to TRUE if the first setleft target is invalid */ boolean_t temp_subs_was_FALSE; union { uint4 unichar_val; unsigned char unibytes_val[4]; } unichar; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; TREF(temp_subs) = FALSE; dqinit(&targchain, exorder); result = (oprtype *)mcalloc(SIZEOF(oprtype)); resptr = put_indr(result); delimiter = sub = last = NULL; /* A SET clause must be entirely alias related or a normal set. Parenthized multiple sets of aliases are not allowed * and will trigger an error. This is because the source and targets of aliases require different values and references * than normal sets do and thus cannot be mixed. */ if (alias_processing = (TK_ASTERISK == window_token)) advancewindow(); if (got_lparen = (TK_LPAREN == window_token)) { if (alias_processing) stx_error(ERR_NOALIASLIST); advancewindow(); TREF(temp_subs) = TRUE; } /* Some explanation: The triples from the left hand side of the SET expression that are * expressly associated with fetching (in case of set $piece/$extract) and/or storing of * the target value are removed from curtchain and placed on the targchain. Later, these * triples will be added to the end of curtchain to do the finishing store of the target * after the righthand side has been evaluated. This is per the M standard. * * Note that SET $PIECE/$EXTRACT have special conditions in which the first argument is not referenced at all. * (e.g. set $piece(^a," ",3,2) in this case 3 > 2 so this should not evaluate ^a and therefore should not * modify the naked indicator). That is, the triples that do these conditional checks need to be inserted * ahead of the OC_GVNAME of ^a, all of which need to be inserted on the targchain. But the conditionalization * can be done only after parsing the first argument of the SET $PIECE and examining the remaining arguments. * Therefore we maintain the "curtargchain" variable which stores the value of the "targchain" at the beginning * of the iteration (at the start of the $PIECE parsing) and all the conditionalization will be inserted right * here which is guaranteed to be ahead of where the OC_GVNAME gets inserted. * * For example, SET $PIECE(^A(x,y),delim,first,last)=RHS will generate a final triple chain as follows * * A - Triples to evaluate subscripts (x,y) of the global ^A * A - Triples to evaluate delim * A - Triples to evaluate first * A - Triples to evaluate last * B - Triples to evaluate RHS * C - Triples to do conditional check (e.g. first > last etc.) * C - Triples to branch around if the checks indicate this is a null operation SET $PIECE * D - Triple that does OC_GVNAME of ^A * D - Triple that does OC_SETPIECE to determine the new value * D - Triple that does OC_GVPUT of the new value into ^A(x,y) * This is the point where the conditional check triples will branch around to if they chose to. * * A - triples that evaluates the arguments/subscripts in the left-hand-side of the SET command * These triples are built in "curtchain" * B - triples that evaluates the arguments/subscripts in the right-hand-side of the SET command * These triples are built in "curtchain" * C - triples that do conditional check for any $PIECE/$EXTRACT in the left side of the SET command. * These triples are built in "curtargchain" * D - triples that generate the reference to the target of the SET and the store into the target. * These triples are built in "targchain" * * Note alias processing does not support the SET *(...)=.. type syntax because the type of argument * created for RHS processing is dependent on the LHS receiver type and we do not support more than one * type of source argument in a single SET. */ first_setleft_invalid = FIRST_SETLEFT_NOTSEEN; curtchain_switched = FALSE; nakedzalias = have_lh_alias = FALSE; save_curtchain = NULL; assert(FIRST_SETLEFT_NOTSEEN != TRUE); assert(FIRST_SETLEFT_NOTSEEN != FALSE); for (parse_warn = FALSE; ; parse_warn = FALSE) { curtargchain = targchain.exorder.bl; jmptrp1 = jmptrp2 = NULL; delim1char = is_extract = FALSE; allow_dzwrtac_as_mident(); /* Allows $ZWRTACxxx as target to be treated as an mident */ switch (window_token) { case TK_IDENT: /* A slight diversion first. If this is a $ZWRTAC set (indication of $ in first char * is currently enough to signify that), then we need to check a few conditions first. * If this is a "naked $ZWRTAC", meaning no numeric suffix, then this is a flag that * all the $ZWRTAC vars in the local variable tree need to be kill *'d which will not * be generating a SET instruction. First we need to verify that fact and make sure * we are not in PARENs and not doing alias processing. Note *any* value can be * specified as the source but while it will be evaluated, it is NOT stored anywhere. */ if ('$' == *window_ident.addr) { /* We have a $ZWRTAC<xx> target */ if (got_lparen) /* We don't allow $ZWRTACxxx to be specified in a parenthesized list. * Verify that first */ SYNTAX_ERROR(ERR_DZWRNOPAREN); if (STR_LIT_LEN(DOLLAR_ZWRTAC) == window_ident.len) { /* Ok, this is a naked $ZWRTAC targeted set */ if (alias_processing) SYNTAX_ERROR(ERR_DZWRNOALIAS); nakedzalias = TRUE; /* This opcode doesn't really need args but it is easier to fit in with the rest * of m_set processing to pass it the result arg, which there may actually be * a use for someday.. */ put = maketriple(OC_CLRALSVARS); put->operand[0] = resptr; dqins(targchain.exorder.bl, exorder, put); advancewindow(); break; } } /* If we are doing alias processing, there are two possibilities: * 1) LHS is unsubscripted - it is an alias variable being created or replaced. Need to parse * the varname as if this were a regular set. * 2) LHS is subscripted - it is an alias container variable being created or replaced. The * processing here is to pass the base variable index to the store routine so bypass the * lvn() call. */ if (!alias_processing || TK_LPAREN == director_token) { /* Normal variable processing or we have a lh alias container */ if (!lvn(&v, OC_PUTINDX, 0)) SYNTAX_ERROR_NOREPORT_HERE; if (OC_PUTINDX == v.oprval.tref->opcode) { dqdel(v.oprval.tref, exorder); dqins(targchain.exorder.bl, exorder, v.oprval.tref); sub = v.oprval.tref; put_oc = OC_PUTINDX; if (TREF(temp_subs)) m_set_create_temporaries(sub, put_oc); } } else { /* Have alias variable. Argument is index into var table rather than pointer to var */ have_lh_alias = TRUE; /* We only want the variable index in this case. Since the entire hash structure to which * this variable is going to be pointing to is changing, doing anything that calls fetch() * is somewhat pointless so we avoid it by just accessing the variable information * directly. */ mvarptr = get_mvaddr(&window_ident); v = put_ilit(mvarptr->mvidx); advancewindow(); } /* Determine correct storing triple */ put = maketriple((!alias_processing ? OC_STO : (have_lh_alias ? OC_SETALS2ALS : OC_SETALSIN2ALSCT))); put->operand[0] = v; put->operand[1] = resptr; dqins(targchain.exorder.bl, exorder, put); break; case TK_CIRCUMFLEX: if (alias_processing) SYNTAX_ERROR(ERR_ALIASEXPECTED); s1 = curtchain->exorder.bl; if (!gvn()) SYNTAX_ERROR_NOREPORT_HERE; for (sub = curtchain->exorder.bl; sub != s1; sub = sub->exorder.bl) { put_oc = sub->opcode; if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc) break; } assert(OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc); dqdel(sub, exorder); dqins(targchain.exorder.bl, exorder, sub); if (TREF(temp_subs)) m_set_create_temporaries(sub, put_oc); put = maketriple(OC_GVPUT); put->operand[0] = resptr; dqins(targchain.exorder.bl, exorder, put); break; case TK_ATSIGN: if (alias_processing) SYNTAX_ERROR(ERR_ALIASEXPECTED); if (!indirection(&v)) SYNTAX_ERROR_NOREPORT_HERE; if (!got_lparen && TK_EQUAL != window_token) { assert(!curtchain_switched); put = newtriple(OC_COMMARG); put->operand[0] = v; put->operand[1] = put_ilit(indir_set); return TRUE; } put = maketriple(OC_INDSET); put->operand[0] = v; put->operand[1] = resptr; dqins(targchain.exorder.bl, exorder, put); break; case TK_DOLLAR: if (alias_processing) SYNTAX_ERROR(ERR_ALIASEXPECTED); advancewindow(); if (TK_IDENT != window_token) SYNTAX_ERROR(ERR_VAREXPECTED); if (TK_LPAREN != director_token) { /* Look for intrinsic special variables */ s1 = curtchain->exorder.bl; if (0 > (index = namelook(svn_index, svn_names, window_ident.addr, window_ident.len))) { STX_ERROR_WARN(ERR_INVSVN); /* sets "parse_warn" to TRUE */ } else if (!svn_data[index].can_set) { STX_ERROR_WARN(ERR_SVNOSET); /* sets "parse_warn" to TRUE */ } advancewindow(); if (!parse_warn) { if (SV_ETRAP != svn_data[index].opcode && SV_ZTRAP != svn_data[index].opcode) { /* Setting of $ZTRAP or $ETRAP must go through opp_svput because they * may affect the stack pointer. All others directly to op_svput(). */ put = maketriple(OC_SVPUT); } else put = maketriple(OC_PSVPUT); put->operand[0] = put_ilit(svn_data[index].opcode); put->operand[1] = resptr; dqins(targchain.exorder.bl, exorder, put); } else { /* OC_RTERROR triple would have been inserted in curtchain by ins_errtriple * (invoked by stx_error). To maintain consistency with the "if" portion of * this code, we need to move this triple to the "targchain". */ tmp = curtchain->exorder.bl; /* corresponds to put_ilit(FALSE) in ins_errtriple */ tmp = tmp->exorder.bl; /* corresponds to put_ilit(in_error) in ins_errtriple */ tmp = tmp->exorder.bl; /* corresponds to newtriple(OC_RTERROR) in ins_errtriple */ assert(OC_RTERROR == tmp->opcode); dqdel(tmp, exorder); dqins(targchain.exorder.bl, exorder, tmp); CHKTCHAIN(&targchain); } break; } /* Only 4 function names allowed on left side: $[Z]Piece and $[Z]Extract */ index = namelook(fun_index, fun_names, window_ident.addr, window_ident.len); if (0 > index) { STX_ERROR_WARN(ERR_INVFCN); /* sets "parse_warn" to TRUE */ /* OC_RTERROR triple would have been inserted in "curtchain" by ins_errtriple * (invoked by stx_error). We need to switch it to "targchain" to be consistent * with every other codepath in this module. */ tmp = curtchain->exorder.bl; /* corresponds to put_ilit(FALSE) in ins_errtriple */ tmp = tmp->exorder.bl; /* corresponds to put_ilit(in_error) in ins_errtriple */ tmp = tmp->exorder.bl; /* corresponds to newtriple(OC_RTERROR) in ins_errtriple */ assert(OC_RTERROR == tmp->opcode); dqdel(tmp, exorder); dqins(targchain.exorder.bl, exorder, tmp); CHKTCHAIN(&targchain); advancewindow(); /* skip past the function name */ advancewindow(); /* skip past the left paren */ /* Parse the remaining arguments until corresponding RIGHT-PAREN/SPACE/EOL is reached */ if (!parse_until_rparen_or_space()) SYNTAX_ERROR_NOREPORT_HERE; } else { switch(fun_data[index].opcode) { case OC_FNPIECE: setop = OC_SETPIECE; break; case OC_FNEXTRACT: is_extract = TRUE; setop = OC_SETEXTRACT; break; case OC_FNZPIECE: setop = OC_SETZPIECE; break; case OC_FNZEXTRACT: is_extract = TRUE; setop = OC_SETZEXTRACT; break; default: SYNTAX_ERROR(ERR_VAREXPECTED); } advancewindow(); advancewindow(); /* Although we see the get (target) variable first, we need to save it's processing * on another chain -- the targchain -- because the retrieval of the target is bypassed * and the naked indicator is not reset if the first/last parameters are not set in a * logical manner (must be > 0 and first <= last). So the evaluation order is * delimiter (if $piece), first, last, RHS of the set and then the target if applicable. * Set up primary action triple now since it is ref'd by the put triples generated below. */ s = maketriple(setop); /* Even for SET[Z]PIECE and SET[Z]EXTRACT, the SETxxxxx opcodes * do not do the final store, they only create the final value TO be * stored so generate the triples that will actually do the store now. * Note we are still building triples on the original curtchain. */ switch (window_token) { case TK_IDENT: if (!lvn(&v, OC_PUTINDX, 0)) SYNTAX_ERROR(ERR_VAREXPECTED); if (OC_PUTINDX == v.oprval.tref->opcode) { dqdel(v.oprval.tref, exorder); dqins(targchain.exorder.bl, exorder, v.oprval.tref); sub = v.oprval.tref; put_oc = OC_PUTINDX; if (TREF(temp_subs)) m_set_create_temporaries(sub, put_oc); } get = maketriple(OC_FNGET); get->operand[0] = v; put = maketriple(OC_STO); put->operand[0] = v; put->operand[1] = put_tref(s); break; case TK_ATSIGN: if (!indirection(&v)) SYNTAX_ERROR(ERR_VAREXPECTED); get = maketriple(OC_INDGET); get->operand[0] = v; get->operand[1] = put_str(0, 0); put = maketriple(OC_INDSET); put->operand[0] = v; put->operand[1] = put_tref(s); break; case TK_CIRCUMFLEX: s1 = curtchain->exorder.bl; if (!gvn()) SYNTAX_ERROR_NOREPORT_HERE; for (sub = curtchain->exorder.bl; sub != s1 ; sub = sub->exorder.bl) { put_oc = sub->opcode; if ((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc) || (OC_GVEXTNAM == put_oc)) break; } assert((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc) || (OC_GVEXTNAM == put_oc)); dqdel(sub, exorder); dqins(targchain.exorder.bl, exorder, sub); if (TREF(temp_subs)) m_set_create_temporaries(sub, put_oc); get = maketriple(OC_FNGVGET); get->operand[0] = put_str(0, 0); put = maketriple(OC_GVPUT); put->operand[0] = put_tref(s); break; default: SYNTAX_ERROR(ERR_VAREXPECTED); } s->operand[0] = put_tref(get); /* Code to fetch args for target triple are on targchain. Put get there now too. */ dqins(targchain.exorder.bl, exorder, get); CHKTCHAIN(&targchain); if (!is_extract) { /* Set $[z]piece */ delimiter = newtriple(OC_PARAMETER); s->operand[1] = put_tref(delimiter); first = newtriple(OC_PARAMETER); delimiter->operand[1] = put_tref(first); /* Process delimiter string ($[z]piece only) */ if (TK_COMMA != window_token) SYNTAX_ERROR(ERR_COMMA); advancewindow(); if (!strexpr(&delimval)) SYNTAX_ERROR_NOREPORT_HERE; assert(TRIP_REF == delimval.oprclass); } else { /* Set $[Z]Extract */ first = newtriple(OC_PARAMETER); s->operand[1] = put_tref(first); } /* Process first integer value */ if (window_token != TK_COMMA) firstval = put_ilit(1); else { advancewindow(); if (!intexpr(&firstval)) SYNTAX_ERROR(ERR_COMMA); assert(firstval.oprclass == TRIP_REF); } first->operand[0] = firstval; if (first_is_lit = (OC_ILIT == firstval.oprval.tref->opcode)) { assert(ILIT_REF ==firstval.oprval.tref->operand[0].oprclass); first_val_lit = firstval.oprval.tref->operand[0].oprval.ilit; } if (TK_COMMA != window_token) { /* There is no "last" value. Only if 1 char literal delimiter and * no "last" value can we generate shortcut code to op_set[z]p1 entry * instead of op_set[z]piece. Note if UTF8 mode is in effect, then this * optimization applies if the literal is one unicode char which may in * fact be up to 4 bytes but will still be passed as a single unsigned * integer. */ if (!is_extract) { delim_mval = &delimval.oprval.tref->operand[0].oprval.mlit->v; valid_char = TRUE; /* Basic assumption unles proven otherwise */ if (delimval.oprval.tref->opcode == OC_LIT && (1 == (gtm_utf8_mode ? MV_FORCE_LEN(delim_mval) : delim_mval->str.len))) { /* Single char delimiter for set $piece */ UNICODE_ONLY( if (gtm_utf8_mode) { /* We have a supposed single char delimiter but it * must be a valid utf8 char to be used by * op_setp1() and MV_FORCE_LEN won't tell us that. */ valid_char = UTF8_VALID(delim_mval->str.addr, (delim_mval->str.addr + delim_mval->str.len), delimlen); if (!valid_char && !badchar_inhibit) UTF8_BADCHAR(0, delim_mval->str.addr, (delim_mval->str.addr + delim_mval->str.len), 0, NULL); } ); if (valid_char || 1 == delim_mval->str.len) { /* This reference to a one character literal or a single * byte invalid utf8 character that needs to be turned into * an explict formated integer literal instead */ unichar.unichar_val = 0; if (!gtm_utf8_mode) { /* Single byte delimiter */ assert(1 == delim_mval->str.len); UNIX_ONLY(s->opcode = OC_SETZP1); VMS_ONLY(s->opcode = OC_SETP1); unichar.unibytes_val[0] = *delim_mval->str.addr; } UNICODE_ONLY( else { /* Potentially multiple bytes in one int */ assert(SIZEOF(int) >= delim_mval->str.len); memcpy(unichar.unibytes_val, delim_mval->str.addr, delim_mval->str.len); s->opcode = OC_SETP1; } ); delimlit = (mint)unichar.unichar_val; delimiter->operand[0] = put_ilit(delimlit); delim1char = TRUE; } } }
int f_text(oprtype *a, opctype op) { int implicit_offset = 0; triple *r, *label; error_def(ERR_TEXTARG); error_def(ERR_RTNNAME); r = maketriple(op); switch (window_token) { case TK_CIRCUMFLEX: implicit_offset = 1; /* CAUTION - fall-through */ case TK_PLUS: r->operand[0] = put_str(zero_mstr.addr, 0); /* Null label - top of routine */ break; case TK_INTLIT: int_label(); /* CAUTION - fall through */ case TK_IDENT: if (!(cmd_qlf.qlf & CQ_LOWER_LABELS)) lower_to_upper((uchar_ptr_t)window_ident.addr, (uchar_ptr_t)window_ident.addr, window_ident.len); r->operand[0] = put_str(window_ident.addr, window_ident.len); advancewindow(); break; case TK_ATSIGN: if (!indirection(&(r->operand[0]))) return FALSE; r->opcode = OC_INDTEXT; break; default: stx_error(ERR_TEXTARG); return FALSE; } assert(TK_PLUS == window_token || TK_CIRCUMFLEX == window_token || TK_RPAREN == window_token || TK_EOL == window_token); if (OC_INDTEXT != r->opcode || TK_PLUS == window_token || TK_CIRCUMFLEX == window_token) { /* Need another parm chained in to deal with offset and routine name except for the case where an * indirect specifies the entire argument. */ label = newtriple(OC_PARAMETER); r->operand[1] = put_tref(label); } if (TK_PLUS != window_token) { if (OC_INDTEXT != r->opcode || TK_CIRCUMFLEX == window_token) /* Set default offset (0 or 1 as computed above) when offset not specified */ label->operand[0] = put_ilit(implicit_offset); else { /* Fill in indirect text for case where indirect specifies entire operand */ r->opcode = OC_INDFUN; r->operand[1] = put_ilit((mint)indir_fntext); } } else { /* Process offset */ advancewindow(); if (!intexpr(&(label->operand[0]))) return FALSE; } if (TK_CIRCUMFLEX != window_token) { /* No routine specified - default to current routine */ if (OC_INDFUN != r->opcode) { if (!run_time) label->operand[1] = put_str(routine_name.addr, routine_name.len); else label->operand[1] = put_tref(newtriple(OC_CURRTN)); } } else { /* Routine has been specified - pull it */ advancewindow(); switch(window_token) { case TK_IDENT: # ifdef GTM_TRIGGER if (TK_HASH == director_token) /* Coagulate tokens as necessary (and available) to allow '#' in the routine name */ advwindw_hash_in_mname_allowed(); # endif label->operand[1] = put_str(window_ident.addr, window_ident.len); advancewindow(); break; case TK_ATSIGN: if (!indirection(&label->operand[1])) return FALSE; r->opcode = OC_INDTEXT; break; default: stx_error(ERR_RTNNAME); return FALSE; } } ins_triple(r); *a = put_tref(r); return TRUE; }
int m_job(void) { int argcnt; triple *ref,*next; oprtype label, offset, routine, plist, timeout, arglst, *argptr, argval; static readonly unsigned char empty_plist[1] = { jp_eol }; bool is_timeout,dummybool; error_def(ERR_MAXACTARG); error_def(ERR_RTNNAME); error_def(ERR_COMMAORRPARENEXP); error_def(ERR_JOBACTREF); label = put_str(zero_ident.c,sizeof(mident)); offset = put_ilit((mint)0); if (!lref(&label, &offset, FALSE, indir_job, TRUE, &dummybool)) return FALSE; if ((TRIP_REF == label.oprclass) && (OC_COMMARG == label.oprval.tref->opcode)) return TRUE; if (TK_CIRCUMFLEX != window_token) { if (!run_time) routine = put_str(routine_name,sizeof(mident)); else routine = put_tref(newtriple(OC_CURRTN)); } else { advancewindow(); switch(window_token) { case TK_IDENT: routine = put_str(window_ident.c,sizeof(mident)); advancewindow(); break; case TK_ATSIGN: if (!indirection(&routine)) return FALSE; break; default: stx_error(ERR_RTNNAME); return FALSE; } } argcnt = 0; if (TK_LPAREN == window_token) { advancewindow(); argptr = &arglst; while(TK_RPAREN != window_token) { if (argcnt > MAX_ACTUALS) { stx_error(ERR_MAXACTARG); return FALSE; } if (TK_PERIOD == window_token) { stx_error(ERR_JOBACTREF); return FALSE; } if (!expr(&argval)) return FALSE; ref = newtriple(OC_PARAMETER); ref->operand[0] = argval; *argptr = put_tref(ref); argptr = &ref->operand[1]; argcnt++; if (TK_COMMA == window_token) advancewindow(); else if (TK_RPAREN != window_token) { stx_error(ERR_COMMAORRPARENEXP); return FALSE; } } advancewindow(); /* jump over close paren */ } if (TK_COLON == window_token) { advancewindow(); if (TK_COLON == window_token) { is_timeout = TRUE; plist = put_str((char *)empty_plist,sizeof(empty_plist)); } else { if (!jobparameters(&plist)) return FALSE; is_timeout = (TK_COLON == window_token); } if (is_timeout) { advancewindow(); if (!intexpr(&timeout)) return FALSE; } else timeout = put_ilit(NO_M_TIMEOUT); } else { is_timeout = FALSE; plist = put_str((char *)empty_plist,sizeof(empty_plist)); timeout = put_ilit(NO_M_TIMEOUT); } ref = newtriple(OC_JOB); ref->operand[0] = put_ilit(argcnt + 5); /* parameter list + five fixed arguments */ next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = label; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = offset; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = routine; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = plist; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = timeout; if (argcnt) next->operand[1] = arglst; if (is_timeout) newtriple(OC_TIMTRU); return TRUE; }
int m_zwatch(void) { boolean_t is_count; opctype op; oprtype count, name,action; triple *next, *ref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; if (TK_MINUS == TREF(window_token)) { advancewindow(); switch (TREF(window_token)) { case TK_ASTERISK: name = put_str(zero_ident.addr, zero_ident.len); count = put_ilit(CANCEL_ALL); advancewindow(); break; case TK_IDENT: name = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len); count = put_ilit(CANCEL_ONE); advancewindow(); break; case TK_ATSIGN: if (!indirection(&name)) return FALSE; count = put_ilit(CANCEL_ONE); break; default: stx_error(ERR_VAREXPECTED); return FALSE; } action = put_str("",0); op = OC_WATCHREF; } else { if (TK_EQUAL == TREF(window_token)) { advancewindow(); op = OC_WATCHMOD; } else op = OC_WATCHREF; switch (TREF(window_token)) { case TK_IDENT: name = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len); advancewindow(); break; case TK_ATSIGN: if (!indirection(&name)) return FALSE; if ((OC_WATCHREF == op) && (TK_COLON != TREF(window_token))) { ref = maketriple(OC_COMMARG); ref->operand[0] = name; ref->operand[1] = put_ilit((mint) indir_zwatch); ins_triple(ref); return TRUE; } break; default: stx_error(ERR_VAREXPECTED); return FALSE; } if (TK_COLON != TREF(window_token)) { action = put_str("",0); count = put_ilit(0); } else { advancewindow(); if (TK_COLON == TREF(window_token)) { is_count = TRUE; action = put_str("", 0); } else { if (EXPR_FAIL == expr(&action, MUMPS_STR)) return FALSE; is_count = (TK_COLON == TREF(window_token)); } if (is_count) { advancewindow(); if (EXPR_FAIL == expr(&count, MUMPS_INT)) return FALSE; } else count = put_ilit(0); } } ref = newtriple(op); ref->operand[0] = name; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = action; next->operand[1] = count; return TRUE; }
int m_zprint(void) { oprtype lab1,lab2,off1,off2,rtn; triple *ref,*next; bool got_some; error_def(ERR_LABELEXPECTED); error_def(ERR_RTNNAME); got_some = FALSE; lab1 = put_str(&zero_ident.c[0],sizeof(mident)); off1 = put_ilit(0); if (window_token != TK_EOL && window_token != TK_SPACE && !lref(&lab1,&off1,TRUE,indir_zprint,TRUE,&got_some)) return FALSE; if (lab1.oprclass == TRIP_REF && lab1.oprval.tref->opcode == OC_COMMARG) return TRUE; if (window_token != TK_CIRCUMFLEX) { if (!run_time) rtn = put_str(routine_name, mid_len ((mident *)routine_name)); else rtn = put_tref(newtriple(OC_CURRTN)); } else { got_some = TRUE; advancewindow(); switch(window_token) { case TK_IDENT: rtn = put_str(window_ident.c, mid_len (&window_ident)); advancewindow(); break; case TK_ATSIGN: if (!indirection(&rtn)) return FALSE; break; default: stx_error(ERR_RTNNAME); return FALSE; } } if (window_token == TK_COLON) { if (!got_some) { stx_error(ERR_LABELEXPECTED); return FALSE; } lab2 = put_str(&zero_ident.c[0],sizeof(mident)); off2 = put_ilit(0); advancewindow(); if (!lref(&lab2,&off2,TRUE,indir_zprint,FALSE,&got_some)) return FALSE; if (!got_some) { stx_error(ERR_LABELEXPECTED); return FALSE; } } else { lab2 = lab1; off2 = off1; } ref = newtriple(OC_ZPRINT); ref->operand[0] = rtn; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = lab1; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = off1; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = lab2; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = off2; return TRUE; }
int m_zprint(void) { boolean_t got_some; oprtype lab1, lab2, off1, off2, rtn; triple *next, *ref; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; got_some = FALSE; lab1 = put_str(zero_ident.addr, zero_ident.len); off1 = put_ilit(0); if ((TK_EOL != TREF(window_token)) && (TK_SPACE != TREF(window_token)) && !lref(&lab1, &off1, TRUE, indir_zprint, TRUE, &got_some)) return FALSE; if ((TRIP_REF == lab1.oprclass) && (OC_COMMARG == lab1.oprval.tref->opcode)) return TRUE; if (TK_CIRCUMFLEX != TREF(window_token)) { /* Routine not specified, use current routine */ rtn = PUT_CURRENT_RTN; } else { got_some = TRUE; advancewindow(); switch (TREF(window_token)) { case TK_IDENT: # ifdef GTM_TRIGGER if (TK_HASH == TREF(director_token)) /* Coagulate tokens as necessary (and available) to allow '#' in the rtn name */ advwindw_hash_in_mname_allowed(); # endif rtn = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len); advancewindow(); break; case TK_ATSIGN: if (!indirection(&rtn)) return FALSE; break; default: stx_error(ERR_RTNNAME); return FALSE; } } if (TK_COLON == TREF(window_token)) { if (!got_some) { stx_error(ERR_LABELEXPECTED); return FALSE; } lab2 = put_str(zero_ident.addr, zero_ident.len); off2 = put_ilit(0); advancewindow(); if (!lref(&lab2, &off2, TRUE, indir_zprint, FALSE, &got_some)) return FALSE; if (!got_some) { stx_error(ERR_LABELEXPECTED); return FALSE; } } else { lab2 = lab1; off2 = off1; } ref = newtriple(OC_ZPRINT); ref->operand[0] = rtn; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = lab1; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = off1; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = lab2; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = off2; return TRUE; }
int f_next( oprtype *a, opctype op) { triple *oldchain, tmpchain, *ref, *r, *triptr; error_def(ERR_VAREXPECTED); error_def(ERR_LVORDERARG); error_def(ERR_GVNEXTARG); DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); switch (window_token) { case TK_IDENT: if (director_token != TK_LPAREN) { stx_error(ERR_LVORDERARG); return FALSE; } if (!lvn(&(r->operand[0]),OC_SRCHINDX,r)) return FALSE; ins_triple(r); break; case TK_CIRCUMFLEX: ref = TREF(shift_side_effects) ? TREF(expr_start) : curtchain->exorder.bl; if (!gvn()) return FALSE; /* the following assumes OC_LIT and OC_GVNAME are all one * gets for an unsubscripted global variable reference */ if ((TREF(shift_side_effects) ? TREF(expr_start) : curtchain)->exorder.bl->exorder.bl->exorder.bl == ref) { stx_error(ERR_GVNEXTARG); return FALSE; } r->opcode = OC_GVNEXT; ins_triple(r); break; case TK_ATSIGN: if (TREF(shift_side_effects)) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!indirection(&(r->operand[0]))) { setcurtchain(oldchain); return FALSE; } r->operand[1] = put_ilit((mint)indir_fnnext); ins_triple(r); 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 { if (!indirection(&(r->operand[0]))) return FALSE; r->operand[1] = put_ilit((mint)indir_fnnext); ins_triple(r); } r->opcode = OC_INDFUN; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } *a = put_tref(r); return TRUE; }
int f_incr(oprtype *a, opctype op) { boolean_t ok; oprtype *increment; triple incrchain, *oldchain, *r, *savptr, targchain, tmpexpr, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); /* may need to evaluate the increment (2nd arg) early and use result later: prepare to juggle triple chains */ dqinit(&targchain, exorder); /* a place for the operation and the target */ dqinit(&tmpexpr, exorder); /* a place to juggle the shifted chain in case it's active */ triptr = TREF(expr_start); savptr = TREF(expr_start_orig); /* but make sure expr_start_orig == expr_start since this is a new chain */ TREF(expr_start_orig) = TREF(expr_start) = &tmpexpr; oldchain = setcurtchain(&targchain); /* save the result of the first argument 'cause it evaluates 2nd */ switch (TREF(window_token)) { case TK_IDENT: /* $INCREMENT() performs an implicit $GET() on a first argument lvn so we use OC_PUTINDX because * we know only at runtime whether to signal an UNDEF error (depending on whether we have * VIEW "NOUNDEF" or "UNDEF" state; op_putindx creates the local variable unconditionally, even if * we have "UNDEF" state, in which case any error in op_fnincr causes an op_kill of that local variable */ ok = (lvn(&(r->operand[0]), OC_PUTINDX, 0)); break; case TK_CIRCUMFLEX: ok = gvn(); r->opcode = OC_GVINCR; r->operand[0] = put_ilit(0); /* dummy fill since emit_code does not like empty operand[0] */ break; case TK_ATSIGN: ok = indirection(&r->operand[0]); r->opcode = OC_INDINCR; break; default: ok = FALSE; break; } if (!ok) { setcurtchain(oldchain); return FALSE; } TREF(expr_start) = triptr; /* restore original shift chain */ TREF(expr_start_orig) = savptr; increment = &r->operand[1]; if (TK_COMMA != TREF(window_token)) *increment = put_ilit(1); /* default optional increment to 1 */ else { dqinit(&incrchain, exorder); /* a place for the increment */ setcurtchain(&incrchain); /* increment expr must evaluate before the glvn in $INCR(glvn,expr) */ advancewindow(); if (EXPR_FAIL == expr(increment, MUMPS_NUM)) { setcurtchain(oldchain); return FALSE; } dqadd(&targchain, &incrchain, exorder); /* dir before targ - this is a violation of info hiding */ setcurtchain(&targchain); } coerce(increment, OCT_MVAL); ins_triple(r); if (&tmpexpr != tmpexpr.exorder.bl) { /* one or more OC_GVNAME may have shifted so add to the end of the shift chain */ assert(TREF(shift_side_effects)); dqadd(TREF(expr_start), &tmpexpr, exorder); /* this is a violation of info hiding */ TREF(expr_start) = tmpexpr.exorder.bl; assert(OC_GVSAVTARG == (TREF(expr_start))->opcode); triptr = newtriple(OC_GVRECTARG); /* restore the result of the last gvn to preserve $referece (the naked) */ triptr->operand[0] = put_tref(TREF(expr_start)); } if (!TREF(shift_side_effects) || (GTM_BOOL != TREF(gtm_fullbool)) || (OC_INDINCR != r->opcode)) { /* put it on the end of the main chain as there's no reason to play more with the ordering */ setcurtchain(oldchain); triptr = (TREF(curtchain))->exorder.bl; dqadd(triptr, &targchain, exorder); /* this is a violation of info hiding */ } else /* need full side effects or indirect 1st argument so put everything on the shift chain */ { /* add the chain after "expr_start" which may be much before "curtchain" */ newtriple(OC_GVSAVTARG); setcurtchain(oldchain); assert(NULL != TREF(expr_start)); dqadd(TREF(expr_start), &targchain, exorder); /* this is a violation of info hiding */ TREF(expr_start) = targchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } /* $increment() args need to avoid side effect processing but that's handled in expritem so eval_expr gets $i()'s SE flag */ *a = put_tref(r); return TRUE; }
triple *entryref(opctype op1, opctype op2, mint commargcode, boolean_t can_commarg, boolean_t labref, boolean_t textname) { oprtype offset, label, routine, rte1; char rtn_text[SIZEOF(mident_fixed)], lab_text[SIZEOF(mident_fixed)]; mident rtnname, labname; mstr rtn_str, lbl_str; triple *ref, *next, *rettrip; boolean_t same_rout; rtnname.len = labname.len = 0; rtnname.addr = &rtn_text[0]; labname.addr = &lab_text[0]; /* These cases don't currently exist but if they start to exist, the code in this * routine needs to be revisited for proper operation as the textname conditions * were assumed not to happen if can_commarg was FALSE (which it is in the one * known use of textname TRUE - in m_zgoto). */ assert(!(can_commarg && textname)); switch (window_token) { case TK_INTLIT: int_label(); /* caution: fall through */ case TK_IDENT: memcpy(labname.addr, window_ident.addr, window_ident.len); labname.len = window_ident.len; advancewindow(); if ((TK_PLUS != window_token) && (TK_CIRCUMFLEX != window_token) && !IS_MCODE_RUNNING && can_commarg) { rettrip = newtriple(op1); rettrip->operand[0] = put_mlab(&labname); return rettrip; } label.oprclass = 0; break; case TK_ATSIGN: if(!indirection(&label)) return NULL; if ((TK_PLUS != window_token) && (TK_CIRCUMFLEX != window_token) && (TK_COLON != window_token) && can_commarg) { rettrip = ref = maketriple(OC_COMMARG); ref->operand[0] = label; ref->operand[1] = put_ilit(commargcode); ins_triple(ref); return rettrip; } labname.len = 0; break; case TK_PLUS: stx_error(ERR_LABELEXPECTED); return NULL; default: labname.len = 0; label.oprclass = 0; break; } if (!labref && (TK_PLUS == window_token)) { /* Have line offset specified */ advancewindow(); if (!intexpr(&offset)) return NULL; } else offset.oprclass = 0; if (TK_CIRCUMFLEX == window_token) { /* Have a routine name specified */ advancewindow(); switch(window_token) { case TK_IDENT: MROUT2XTERN(window_ident.addr, rtnname.addr, window_ident.len); rtn_str.len = rtnname.len = window_ident.len; rtn_str.addr = rtnname.addr; advancewindow(); if (!IS_MCODE_RUNNING) { /* Triples for indirect code */ same_rout = (MIDENT_EQ(&rtnname, &routine_name) && can_commarg); if (!textname) { /* Resolve routine and label names to addresses for most calls */ if (!label.oprclass && !offset.oprclass) { /* Routine only (no label or offset) */ if (same_rout) { rettrip = newtriple(op1); rettrip->operand[0] = put_mlab(&labname); } else { rettrip = maketriple(op2); if (rtnname.addr[0] == '%') rtnname.addr[0] = '_'; rettrip->operand[0] = put_cdlt(&rtn_str); mlabel2xtern(&lbl_str, &rtnname, &labname); rettrip->operand[1] = put_cdlt(&lbl_str); ins_triple(rettrip); } return rettrip; } else if (!same_rout) { rte1 = put_str(rtn_str.addr, rtn_str.len); if (rtnname.addr[0] == '%') rtnname.addr[0] = '_'; routine = put_cdlt(&rtn_str); ref = newtriple(OC_RHDADDR); ref->operand[0] = rte1; ref->operand[1] = routine; routine = put_tref(ref); } else routine = put_tref(newtriple(OC_CURRHD)); } else { /* Return the actual names used */ if (!label.oprclass && !offset.oprclass) { /* Routine only (no label or offset) */ rettrip = maketriple(op2); rettrip->operand[0] = put_str(rtn_str.addr, rtn_str.len); ref = newtriple(OC_PARAMETER); ref->operand[0] = put_str(labname.addr, labname.len); ref->operand[1] = put_ilit(0); rettrip->operand[1] = put_tref(ref); ins_triple(rettrip); return rettrip; } else routine = put_str(rtn_str.addr, rtn_str.len); } } else { /* Triples for normal compiled code */ routine = put_str(rtn_str.addr, rtn_str.len); if (!textname) { /* If not returning text name, convert text name to routine header address */ ref = newtriple(OC_RHDADDR1); ref->operand[0] = routine; routine = put_tref(ref); } } break; case TK_ATSIGN: if (!indirection(&routine)) return NULL; if (!textname) { /* If not returning text name, convert text name to routine header address */ ref = newtriple(OC_RHDADDR1); ref->operand[0] = routine; routine = put_tref(ref); } break; default: stx_error(ERR_RTNNAME); return NULL; } } else { if (!label.oprclass && (0 == labname.len)) { stx_error(ERR_LABELEXPECTED); return NULL; } if (!textname) routine = put_tref(newtriple(OC_CURRHD)); else { /* If we need a name, the mechanism to retrieve it differs between normal and indirect compilation */ if (!IS_MCODE_RUNNING) /* For normal compile, use routine name set when started compile */ routine = put_str(routine_name.addr, routine_name.len); else /* For an indirect compile, obtain the currently running routine header and pull the routine * name out of that. */ routine = put_str(frame_pointer->rvector->routine_name.addr, frame_pointer->rvector->routine_name.len); } } if (!offset.oprclass) offset = put_ilit(0); if (!label.oprclass) label = put_str(labname.addr, labname.len); ref = textname ? newtriple(OC_PARAMETER) : newtriple(OC_LABADDR); ref->operand[0] = label; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = offset; if (!textname) next->operand[1] = routine; /* Not needed if giving text names */ rettrip = next = newtriple(op2); next->operand[0] = routine; next->operand[1] = put_tref(ref); return rettrip; }
int m_zbreak(void) { triple *ref, *next; oprtype label, offset, routine, action, count; bool cancel, cancel_all, is_count, dummybool; error_def(ERR_LABELEXPECTED); error_def(ERR_RTNNAME); label = put_str((char *)&zero_ident.c[0], sizeof(mident)); cancel_all = FALSE; action = put_str("B", 1); if (window_token == TK_MINUS) { advancewindow(); cancel = TRUE; count = put_ilit((mint)CANCEL_ONE); } else { cancel = FALSE; count = put_ilit((mint)0); } if (window_token == TK_ASTERISK) { if (cancel) { advancewindow(); cancel_all = TRUE; if (!run_time) routine = put_str(&routine_name[0], sizeof(mident)); else routine = put_tref(newtriple(OC_CURRTN)); offset = put_ilit((mint) 0); count = put_ilit((mint) CANCEL_ALL); } else { stx_error(ERR_LABELEXPECTED); return FALSE; } } else { offset = put_ilit((mint) 0); if (!lref(&label,&offset, TRUE, indir_zbreak, !cancel, &dummybool)) return FALSE; if (label.oprclass == TRIP_REF && label.oprval.tref->opcode == OC_COMMARG) return TRUE; if (window_token != TK_CIRCUMFLEX) { if (!run_time) routine = put_str(&routine_name[0], sizeof(mident)); else routine = put_tref(newtriple(OC_CURRTN)); } else { advancewindow(); switch(window_token) { case TK_IDENT: routine = put_str(&window_ident.c[0], sizeof(mident)); advancewindow(); break; case TK_ATSIGN: if (!indirection(&routine)) return FALSE; break; default: stx_error(ERR_RTNNAME); return FALSE; } } if (!cancel && window_token == TK_COLON) { advancewindow(); if (window_token == TK_COLON) { is_count = TRUE; action = put_str("B",1); } else { if (!strexpr(&action)) return FALSE; is_count = window_token == TK_COLON; } if (is_count) { advancewindow(); if (!intexpr(&count)) return FALSE; } } } ref = newtriple(OC_SETZBRK); ref->operand[0] = label; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = offset; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = routine; next = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(next); next->operand[0] = action; ref = newtriple(OC_PARAMETER); next->operand[1] = put_tref(ref); ref->operand[0] = count; return TRUE; }