void coerce(oprtype *a,unsigned short new_type) { mliteral *lit; opctype conv, old_op; triple *ref, *coerc; assert (new_type == OCT_MVAL || new_type == OCT_MINT || new_type == OCT_BOOL); assert (a->oprclass == TRIP_REF); ref = a->oprval.tref; old_op = ref->opcode; if (new_type & oc_tab[old_op].octype) return; if (old_op == OC_COMVAL || old_op == OC_COMINT) { dqdel(ref,exorder); ref = ref->operand[0].oprval.tref; old_op = ref->opcode; if (new_type & oc_tab[old_op].octype) return; } else if (old_op == OC_LIT && new_type == OCT_MINT) { lit = ref->operand[0].oprval.mlit; if (!(++lit->rt_addr)) dqdel(lit, que); ref->opcode = OC_ILIT; ref->operand[0].oprclass = ILIT_REF; ref->operand[0].oprval.ilit = MV_FORCE_INT(&(lit->v)); return; } if (new_type == OCT_BOOL) conv = OC_COBOOL; else if (new_type == OCT_MINT) conv = OC_COMINT; else conv = OC_COMVAL; coerc = newtriple(conv); coerc->operand[0] = put_tref(ref); *a = put_tref(coerc); return; }
void make_commarg(oprtype *x,mint ind) { triple *ref; assert(x->oprclass == TRIP_REF); ref = x->oprval.tref; if (ref->opcode != OC_INDGLVN) { assert(ref->opcode == OC_COMVAL || ref->opcode == OC_COMINT || ref->opcode == OC_COBOOL); dqdel(ref,exorder); assert(ref->operand[0].oprclass == TRIP_REF); ref = ref->operand[0].oprval.tref; assert(ref->opcode == OC_INDGLVN); } ref->opcode = OC_COMMARG; ref->operand[1] = put_ilit(ind); return; }
void bx_boollit_tail(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr) /* search the Boolean in t (recursively) for literal leaves; the logic is similar to bx_tail * the rest of the arguments parallel those in bx_boolop and used primarily handling basic Boolean operations (ON, NOR, AND, NAND) * to get the jump target and sense right for the left-hand operand of the operation * jmp_type_one gives the sense of the jump associated with the first operand * jmp_to_next gives whether we need a second jump to complete the operation * sense gives the sense of the requested operation * *addr points the operand for the jump and is eventually used by logic back in the invocation stack to fill in a target location */ { boolean_t sin[ARRAYSIZE(t->operand)], tv[ARRAYSIZE(t->operand)]; int com, comval, dummy, j, neg, num, tvr; mval *mv, *v[ARRAYSIZE(t->operand)]; opctype c; oprtype *i, *p; triple *cob[ARRAYSIZE(t->operand)], *ref0, *tl[ARRAYSIZE(t->operand)]; assert(OCT_BOOL & oc_tab[t->opcode].octype); assert(TRIP_REF == t->operand[0].oprclass); assert((OC_COBOOL != t->opcode) && (OC_COM != t->opcode) || (TRIP_REF == t->operand[1].oprclass)); for (i = t->operand, j = 0; i < ARRAYTOP(t->operand); i++, j++) { /* checkout an operand to see if we can simplify it */ p = i; com = 0; for (tl[j] = i->oprval.tref; OCT_UNARY & oc_tab[(c = tl[j]->opcode)].octype; tl[j] = p->oprval.tref) { /* find the real object of affection; WARNING assignment above */ assert((TRIP_REF == tl[j]->operand[0].oprclass) && (NO_REF == tl[j]->operand[1].oprclass)); com ^= (OC_COM == c); /* if we make a recursive call below, COM matters, but NEG and FORCENUM don't */ p = &tl[j]->operand[0]; } if (OCT_ARITH & oc_tab[c].octype) ex_tail(p); /* chained arithmetic */ else if (OCT_BOOL & oc_tab[c].octype) { /* recursively check an operand */ sin[j] = sense; p = addr; if (!j && !(OCT_REL & oc_tab[t->opcode].octype)) { /* left hand operand of parent */ sin[j] = jmp_type_one; if (jmp_to_next) { /* left operands need extra attention to decide between jump next or to the end */ p = (oprtype *)mcalloc(SIZEOF(oprtype)); *p = put_tjmp(t); } } bx_boollit(tl[j], sin[j] ^ com, p); } if ((OC_JMPTRUE != tl[j]->opcode) && (OC_JMPFALSE != tl[j]->opcode) && (OC_LIT != tl[j]->opcode)) return; /* this operation doesn't qualify */ com = comval = neg = num = 0; cob[j] = NULL; for (ref0 = i->oprval.tref; OCT_UNARY & oc_tab[(c = ref0->opcode)].octype; ref0 = ref0->operand[0].oprval.tref) { /* we may be able to clean up this operand; WARNING assignment above */ assert((TRIP_REF == ref0->operand[0].oprclass) && (NO_REF == ref0->operand[1].oprclass)); num += (OC_FORCENUM == c); com += (OC_COM == c); if (!com) /* "outside" com renders neg mute */ neg ^= (OC_NEG == c); if (!comval && (NULL == cob[j])) { if (comval = (OC_COMVAL == c)) /* WARNING assignment */ { if (ref0 != t->operand[j].oprval.tref) dqdel(t->operand[j].oprval.tref, exorder); t->operand[j].oprval.tref = tl[j]; /* need mval: no COBOOL needed */ } else if (OC_COBOOL == c) { /* the operand needs a COBOOL in case its operator remains unresolved */ cob[j] = t->operand[j].oprval.tref; if (ref0 == cob[j]) continue; /* already where it belongs */ cob[j]->opcode = OC_COBOOL; cob[j]->operand[0].oprval.tref = tl[j]; } else if (ref0 == t->operand[j].oprval.tref) continue; } dqdel(ref0, exorder); } assert(ref0 == tl[j]); if (!comval && (NULL == cob[j]) && (tl[j] != t->operand[j].oprval.tref)) { /* left room for a COBOOL, but there's no need */ dqdel(t->operand[j].oprval.tref, exorder); t->operand[j].oprval.tref = tl[j]; } if ((OC_JMPTRUE == ref0->opcode) || (OC_JMPFALSE == ref0->opcode)) { /* switch to a literal representation of TRUE / FALSE */ assert(INDR_REF == ref0->operand[0].oprclass); ref0->operand[1] = ref0->operand[0]; /* track info as we switch opcode */ PUT_LITERAL_TRUTH((sin[j] ? OC_JMPFALSE : OC_JMPTRUE) == ref0->opcode, ref0); ref0->opcode = OC_LIT; com = 0; /* already accounted for by sin */ } assert((OC_LIT == ref0->opcode) && (MLIT_REF == ref0->operand[0].oprclass)); v[j] = &ref0->operand[0].oprval.mlit->v; if (com) { /* any complement reduces the literal value to [unsigned] 1 or 0 */ unuse_literal(v[j]); tv[j] = (0 == v[j]->m[1]); assert(ref0 == tl[j]); PUT_LITERAL_TRUTH(tv[j], ref0); v[j] = &ref0->operand[0].oprval.mlit->v; num = 0; /* any complement trumps num */ } if (neg || num) { /* get literal into uniform state */ unuse_literal(v[j]); mv = (mval *)mcalloc(SIZEOF(mval)); *mv = *v[j]; if (neg) { if (MV_INT & mv->mvtype) { if (0 != mv->m[1]) mv->m[1] = -mv->m[1]; else mv->sgn = 0; } else if (MV_NM & mv->mvtype) mv->sgn = !mv->sgn; } else s2n(mv); n2s(mv); v[j] = mv; assert(ref0 == tl[j]); put_lit_s(v[j], ref0); } } assert(tl[0] != tl[1]); /* start processing a live one */ for (tvr = j, j = 0; j < tvr; j++) { /* both arguments are literals, so do the operation at compile time */ if (NULL != cob[j]) dqdel(cob[j], exorder); v[j] = &tl[j]->operand[0].oprval.mlit->v; tv[j] = (0 != v[j]->m[1]); unuse_literal(v[j]); tl[j]->opcode = OC_NOOP; tl[j]->operand[0].oprclass = NO_REF; } t->operand[1].oprclass = NO_REF; switch (c = t->opcode) /* WARNING assignment */ { /* optimize the Boolean operations here */ case OC_NAND: case OC_AND: tvr = (tv[0] && tv[1]); break; case OC_NOR: case OC_OR: tvr = (tv[0] || tv[1]); break; case OC_NCONTAIN: case OC_CONTAIN: tvr = 1; (void)matchc(v[1]->str.len, (unsigned char *)v[1]->str.addr, v[0]->str.len, (unsigned char *)v[0]->str.addr, &dummy, &tvr); tvr ^= 1; break; case OC_NEQU: case OC_EQU: tvr = is_equ(v[0], v[1]); break; case OC_NFOLLOW: case OC_FOLLOW: tvr = 0 < memvcmp(v[0]->str.addr, v[0]->str.len, v[1]->str.addr, v[1]->str.len); break; case OC_NGT: case OC_GT: tvr = 0 < numcmp(v[0], v[1]); break; case OC_NLT: case OC_LT: tvr = 0 > numcmp(v[0], v[1]); break; case OC_NPATTERN: case OC_PATTERN: tvr = !(*(uint4 *)v[1]->str.addr) ? do_pattern(v[0], v[1]) : do_patfixed(v[0], v[1]); break; case OC_NSORTS_AFTER: case OC_SORTS_AFTER: tvr = 0 < sorts_after(v[0], v[1]); break; default: assertpro(FALSE); } tvr ^= !sense; t->operand[0] = put_indr(addr); t->opcode = tvr ? OC_JMPFALSE : OC_JMPTRUE; return; }
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 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 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 m_zwrite(void) { int4 pcount; /* parameter count */ triple *ref,*ref1,*head,*last,*count; opctype op; oprtype name,limit; mval mv; mint code; mint subscount; char c; bool pat; error_def(ERR_VAREXPECTED); error_def(ERR_RPARENMISSING); error_def(ERR_ZWRSPONE); error_def(ERR_COMMA); subscount = 0; count = 0; pat = FALSE; if (window_token == TK_CIRCUMFLEX) { advancewindow(); op = OC_GVZWRITE; } else { op = OC_LVZWRITE; } switch(window_token) { case TK_SPACE: case TK_EOL: if (op == OC_GVZWRITE) { stx_error(ERR_VAREXPECTED); return FALSE; } else { op = OC_LVPATWRITE; } head = maketriple(op); head->operand[0] = put_ilit((mint)3); ref1 = newtriple(OC_PARAMETER); head->operand[1] = put_tref(ref1); ref1->operand[0] = put_ilit(0); /* shows not from zshow */ ref = newtriple(OC_PARAMETER); ref1->operand[1] = put_tref(ref); ref->operand[0] = put_str((char *)pat_everything,sizeof_pat_everything); MV_FORCE_MVAL(&mv,ZWRITE_ASTERISK) ; ref->operand[1] = put_lit(&mv); ins_triple(head); return TRUE; case TK_IDENT: name = put_str(&window_ident.c[0],mid_len(&window_ident)); advancewindow(); break; case TK_LPAREN: if (op != OC_GVZWRITE) /* naked reference */ { stx_error(ERR_VAREXPECTED); return FALSE; } name = put_str(&window_ident.c[0], 0); break; case TK_ATSIGN: if (!indirection(&name)) return FALSE; if (op == OC_LVZWRITE && window_token != TK_LPAREN) { ref = maketriple(OC_COMMARG); ref->operand[0] = name; ref->operand[1] = put_ilit(indir_zwrite); ins_triple(ref); return TRUE; } ref = newtriple(OC_INDPAT); ref->operand[0] = name; name = put_tref(ref); break; case TK_QUESTION: advancewindow(); source_column = last_source_column; if (!compile_pattern(&name,FALSE)) return FALSE; if (op == OC_LVZWRITE) op = OC_LVPATWRITE; pat = TRUE; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } head = maketriple(op); last = newtriple(OC_PARAMETER); head->operand[1] = put_tref(last); pcount = 1; if (op == OC_LVPATWRITE || op == OC_GVZWRITE) { pcount++; last->operand[0] = put_ilit((op == OC_GVZWRITE ? pat : 0)); ref = newtriple(OC_PARAMETER); last->operand[1] = put_tref(ref); last = ref; if (op == OC_GVZWRITE) { pcount++; count = last; ref = newtriple(OC_PARAMETER); last->operand[1] = put_tref(ref); last = ref; } } last->operand[0] = name; if (window_token != TK_LPAREN) { pcount++; if (pat) { MV_FORCE_MVAL(&mv,ZWRITE_END) ; } else { subscount++ ; MV_FORCE_MVAL(&mv,ZWRITE_ASTERISK) ; } last->operand[1] = put_lit(&mv); head->operand[0] = put_ilit(pcount); if (count) count->operand[0] = put_ilit(subscount); ins_triple(head); return TRUE; } advancewindow(); for(;;) { ref = newtriple(OC_PARAMETER); last->operand[1] = put_tref(ref); switch (window_token) { case TK_RPAREN: dqdel(ref,exorder); advancewindow(); MV_FORCE_MVAL(&mv,ZWRITE_END) ; last->operand[1] = put_lit(&mv); pcount++; head->operand[0] = put_ilit((mint)pcount); if (count) count->operand[0] = put_ilit(subscount); ins_triple(head); return TRUE; case TK_ASTERISK: dqdel(ref,exorder); advancewindow(); if (window_token != TK_RPAREN) { stx_error(ERR_RPARENMISSING); return FALSE; } advancewindow(); MV_FORCE_MVAL(&mv,ZWRITE_ASTERISK) ; last->operand[1] = put_lit(&mv); pcount++; subscount++; head->operand[0] = put_ilit((mint)pcount); if (count) count->operand[0] = put_ilit(subscount); ins_triple(head); return TRUE; case TK_QUESTION: advancewindow(); source_column = last_source_column; if (!compile_pattern(&limit,FALSE)) return FALSE; if (window_token != TK_COMMA && window_token != TK_RPAREN) { stx_error(ERR_ZWRSPONE); return FALSE; } if (window_token == TK_COMMA) advancewindow(); subscount++; MV_FORCE_MVAL(&mv,ZWRITE_PATTERN) ; ref->operand[0] = put_lit(&mv); pcount++; ref1 = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(ref1); ref1->operand[0] = limit; last = ref1; pcount++; continue; case TK_COLON: if ((c = director_token) != TK_RPAREN) { if (c != TK_COMMA) { advancewindow(); MV_FORCE_MVAL(&mv,ZWRITE_UPPER) ; ref->operand[0] = put_lit(&mv); pcount++; subscount++; break; } advancewindow(); } /* caution: fall through */ case TK_COMMA: advancewindow(); MV_FORCE_MVAL(&mv,ZWRITE_ALL) ; ref->operand[0] = put_lit(&mv); pcount++; subscount++; last = ref; continue; default: if (!expr(&limit)) return FALSE; subscount++; last = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(last); last->operand[0] = limit; pcount++; if ((c = window_token) == TK_COLON) { code = ZWRITE_LOWER; advancewindow(); c = window_token; } else code = ZWRITE_VAL; switch (c) { case TK_COMMA: advancewindow(); /* caution: fall through */ case TK_RPAREN: MV_FORCE_MVAL(&mv,code) ; ref->operand[0] = put_lit(&mv); pcount++; continue; default: if (code == ZWRITE_VAL) { stx_error(ERR_COMMA); return FALSE; } MV_FORCE_MVAL(&mv,ZWRITE_BOTH) ; ref->operand[0] = put_lit(&mv); pcount++; ref = last; break; } break; } if (!expr(&limit)) return FALSE; last = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(last); last->operand[0] = limit; pcount++; if (window_token == TK_COMMA) { advancewindow(); } } }
void bx_boolop(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr) { boolean_t expr_fini; oprtype *adj_addr, *i, *p; tbp *tripbp; triple *ref0, *ref1, *ref2, *t0, *t1; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; assert(((1 & sense) == sense) && ((1 & jmp_to_next) == jmp_to_next) && ((1 & jmp_type_one) == jmp_type_one)); assert((TRIP_REF == t->operand[0].oprclass) && (TRIP_REF == t->operand[1].oprclass)); if (jmp_to_next) { p = (oprtype *)mcalloc(SIZEOF(oprtype)); *p = put_tjmp(t); } else p = addr; if (GTM_BOOL == TREF(gtm_fullbool) || !TREF(saw_side_effect)) { /* nice simple short circuit */ assert(NULL == TREF(boolchain_ptr)); bx_tail(t->operand[0].oprval.tref, jmp_type_one, p); bx_tail(t->operand[1].oprval.tref, sense, addr); t->opcode = OC_NOOP; t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS; return; } /* got a side effect and don't want them short circuited */ /* This code violates info hiding big-time and relies on the original technique of setting up a jump ladder * then it changes the jumps into stotemps and creates a new ladder using the saved evaluations * for the relocated jumps to use for controlling conditional transfers, When the stotemps reference mvals, * they are optimized away when possible. The most interesting part is getting the addresses for the new jump * operands (targets) - see comment below. In theory we could turn this technique on and off around each side effect, * but that's even more complicated, requiring additional instructions, and we don't predict the typical boolean * expression has enough subexpressions to justify the extra trouble, although the potential pay-back would be to * avoid unnecessary global references - again, not expecting that many in a typical boolean expresion. */ assert(TREF(shift_side_effects)); if (expr_fini = (NULL == TREF(boolchain_ptr))) /* NOTE assignment */ { /* initialize work on boolean section of the AST */ TREF(boolchain_ptr) = &(TREF(boolchain)); dqinit(TREF(boolchain_ptr), exorder); t0 = t->exorder.fl; if (NULL == TREF(bool_targ_ptr)) { /* first time - set up anchor */ TREF(bool_targ_ptr) = &(TREF(bool_targ_anchor)); /* mcalloc won't persist over multiple complies */ dqinit(TREF(bool_targ_ptr), que); } else /* queue should be empty */ assert((TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.fl) && (TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.bl)); /* ex_tail wraps bools that produce a value with OC_BOOLINIT (clr) and OC_BOOLFINI (set) */ assert((OC_BOOLFINI != t0->opcode) || ((OC_COMVAL == t0->exorder.fl->opcode) && (TRIP_REF == t0->operand[0].oprclass))); } for (i = t->operand; i < ARRAYTOP(t->operand); i++) { assert(NULL != TREF(boolchain_ptr)); t1 = i->oprval.tref; if (&(t->operand[0]) == i) bx_tail(t1, jmp_type_one, p); /* do normal transform */ else { /* operand[1] */ bx_tail(t1, sense, addr); /* do normal transform */ if (!expr_fini) break; /* only need to relocate last operand[1] */ } if (OC_NOOP == t1->opcode) { /* the technique of sprinkling noops means fishing around for the actual instruction */ do { t1 = t1->exorder.bl; assert(TREF(curtchain) != t1->exorder.bl); } while (OC_NOOP == t1->opcode); if ((oc_tab[t1->opcode].octype & OCT_JUMP) && (OC_JMPTSET != t1->opcode) && (OC_JMPTCLR != t1->opcode)) t1 = t1->exorder.bl; if (OC_NOOP == t1->opcode) { for (t1 = i->oprval.tref; OC_NOOP == t1->opcode; t1 = t1->exorder.fl) assert(TREF(curtchain) != t1->exorder.fl); } } assert(OC_NOOP != t1->opcode); assert((oc_tab[t1->exorder.fl->opcode].octype & OCT_JUMP) ||(OC_JMPTSET != t1->exorder.fl->opcode) || (OC_JMPTCLR != t1->exorder.fl->opcode)); ref0 = maketriple(t1->opcode); /* copy operation for place in new ladder */ ref1 = (TREF(boolchain_ptr))->exorder.bl; /* common setup for above op insert */ switch (t1->opcode) { /* time to subvert original jump ladder entry */ case OC_COBOOL: /* insert COBOOL and copy of following JMP in boolchain; overlay them with STOTEMP and NOOP */ assert(TRIP_REF == t1->operand[0].oprclass); dqins(ref1, exorder, ref0); if (oc_tab[t1->operand[0].oprval.tref->opcode].octype & OCT_MVAL) { /* do we need a STOTEMP? */ switch (t1->operand[0].oprval.tref->opcode) { case OC_INDGLVN: /* indirect actions not happy without STOTEMP */ case OC_INDNAME: case OC_VAR: /* variable could change so must save it */ t1->opcode = OC_STOTEMP; ref0->operand[0] = put_tref(t1);/* new COBOOL points to this OC_STOTEMP */ break; default: /* else no temporary if it's mval */ ref0->operand[0] = put_tref(t1->operand[0].oprval.tref); t1->opcode = OC_NOOP; t1->operand[0].oprclass = NOCLASS; } } else { /* make it an mval instead of COBOOL now */ t1->opcode = OC_COMVAL; ref0->operand[0] = put_tref(t1); /* new COBOOL points to this OC_COMVAL */ } t1 = t1->exorder.fl; ref0 = maketriple(t1->opcode); /* create new jmp on result of coerce */ ref0->operand[0] = t1->operand[0]; t1->opcode = OC_NOOP; /* wipe out original jmp */ t1->operand[0].oprclass = NOCLASS; break; case OC_CONTAIN: case OC_EQU: case OC_FOLLOW: case OC_NUMCMP: case OC_PATTERN: case OC_SORTS_AFTER: /* insert copies of orig OC and following JMP in boolchain & overly originals with STOTEMPs */ assert(TRIP_REF == t1->operand[0].oprclass); assert(TRIP_REF == t1->operand[1].oprclass); dqins(ref1, exorder, ref0); if (OC_VAR == t1->operand[0].oprval.tref->opcode) { /* VAR could change so must save it */ t1->opcode = OC_STOTEMP; /* overlay the original op with a STOTEMP */ ref0->operand[0] = put_tref(t1); /* new op points to thi STOTEMP */ } else { /* no need for a temporary unless it's a VAR */ ref0->operand[0] = put_tref(t1->operand[0].oprval.tref); t1->opcode = OC_NOOP; } ref1 = t1; t1 = t1->exorder.fl; ref2 = maketriple(t1->opcode); /* copy jmp */ ref2->operand[0] = t1->operand[0]; if (OC_VAR == ref1->operand[1].oprval.tref->opcode) { /* VAR could change so must save it */ ref0->operand[1] = put_tref(t1); /* new op points to STOTEMP overlaying the jmp */ t1->operand[0] = ref1->operand[1]; t1->opcode = OC_STOTEMP; /* overlay jmp with 2nd STOTEMP */ } else { /* no need for a temporary unless it's a VAR */ ref0->operand[1] = put_tref(ref1->operand[1].oprval.tref); t1->opcode = OC_NOOP; t1->operand[0].oprclass = NOCLASS; } if (OC_NOOP == ref1->opcode) /* does op[0] need cleanup? */ ref1->operand[0].oprclass = ref1->operand[1].oprclass = NOCLASS; ref0 = ref2; break; case OC_JMPTSET: case OC_JMPTCLR: /* move copy of jmp to boolchain and NOOP it */ ref0->operand[0] = t1->operand[0]; /* new jmpt gets old target */ ref2 = maketriple(OC_NOOP); /* insert a NOOP in new chain inplace of COBOOL */ dqins(ref1, exorder, ref2); t1->opcode = OC_NOOP; /* wipe out original jmp */ t1->operand[0].oprclass = NOCLASS; break; default: assertpro(FALSE); } assert((OC_STOTEMP == t1->opcode) || (OC_NOOP == t1->opcode) || (OC_COMVAL == t1->opcode)); assert(oc_tab[ref0->opcode].octype & OCT_JUMP); ref1 = (TREF(boolchain_ptr))->exorder.bl; dqins(ref1, exorder, ref0); /* common insert for new jmp */ } assert(oc_tab[t->opcode].octype & OCT_BOOL); t->opcode = OC_NOOP; /* wipe out the original boolean op */ t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS; tripbp = &t->jmplist; /* borrow jmplist to track jmp targets */ assert(NULL == tripbp->bpt); assert((tripbp == tripbp->que.fl) && (tripbp == tripbp->que.bl)); tripbp->bpt = jmp_to_next ? (TREF(boolchain_ptr))->exorder.bl : ref0; /* point op triple at op[1] position or op[0] */ dqins(TREF(bool_targ_ptr), que, tripbp); /* queue jmplist for clean-up */ if (!expr_fini) return; /* time to deal with new jump ladder */ assert(NULL != TREF(boolchain_ptr)); assert(NULL != TREF(bool_targ_ptr)); assert(TREF(bool_targ_ptr) != (TREF(bool_targ_ptr))->que.fl); assert(t0->exorder.bl == t); assert(t0 == t->exorder.fl); dqadd(t, TREF(boolchain_ptr), exorder); /* insert the new jump ladder */ ref0 = (TREF(boolchain_ptr))->exorder.bl->exorder.fl; t0 = t->exorder.fl; if (ref0 == TREF(curtchain)) { /* add a safe target */ newtriple(OC_NOOP); ref0 = (TREF(curtchain))->exorder.bl; } assert((OC_COBOOL == t0->opcode) ||(OC_JMPTSET != t0->opcode) || (OC_JMPTCLR != t0->opcode)) ; t0 = t0->exorder.fl; assert(oc_tab[t0->opcode].octype & OCT_JUMP); for (; (t0 != ref0) && oc_tab[t0->opcode].octype & OCT_JUMP; t0 = t0->exorder.fl) { /* process replacement jmps */ adj_addr = &t0->operand[0]; assert(INDR_REF == adj_addr->oprclass); if (NULL != (t1 = (adj_addr = adj_addr->oprval.indr)->oprval.tref)) { /* need to adjust target; NOTE assignments above */ if (OC_BOOLFINI != t1->opcode) { /* not past the end of the new chain */ assert(TJMP_REF == adj_addr->oprclass); if ((t == t1) || (t1 == ref0)) ref1 = ref0; /* adjust to end of boolean expression */ else { /* old target should have jmplist entry */ /* from the jmp jmplisted in the old target we move past the next * test (or NOOP) and jmp which correspond to the old target and pick * the subsequent test (or NOOP) and jmp which correspond to those that originally followed * the logic after the old target and are therefore the appropriate new target for this jmp */ assert(OC_NOOP == t1->opcode); assert(&(t1->jmplist) != t1->jmplist.que.fl); assert(NULL != t1->jmplist.bpt); assert(oc_tab[t1->jmplist.bpt->opcode].octype & OCT_JUMP); ref1 = t1->jmplist.bpt->exorder.fl; assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_NOOP == ref1->opcode)); assert(oc_tab[ref1->exorder.fl->opcode].octype & OCT_JUMP); ref1 = ref1->exorder.fl->exorder.fl; assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_BOOLFINI == ref1->opcode) || ((OC_NOOP == ref1->opcode) && ((OC_JMPTCLR == ref1->exorder.fl->opcode) || (OC_JMPTSET == ref1->exorder.fl->opcode) || (TREF(curtchain) == ref1->exorder.fl)))); } t0->operand[0] = put_tjmp(ref1); /* no indrection simplifies later interations */ } } t0 = t0->exorder.fl; if ((OC_BOOLFINI == t0->opcode) || (TREF(curtchain) == t0->exorder.fl)) break; assert((oc_tab[t0->opcode].octype & OCT_BOOL) || (OC_JMPTSET == t0->exorder.fl->opcode) || (OC_JMPTCLR == t0->exorder.fl->opcode)); } dqloop(TREF(bool_targ_ptr), que, tripbp) /* clean up borrowed jmplist entries */ { dqdel(tripbp, que); tripbp->bpt = NULL; }
int m_if(void) { triple *ref0, *ref1, *ref2, *jmpref, ifpos_in_chain, *triptr; oprtype x, y, *ta_opr; bool first_time, t_set, is_commarg; typedef struct jmpchntype { struct { struct jmpchntype *fl,*bl; }link; triple *jmptrip; }jmpchn; jmpchn *jmpchain,*nxtjmp; error_def(ERR_SPOREOL); error_def(ERR_INDEXTRACHARS); ifpos_in_chain = pos_in_chain; jmpchain = (jmpchn*) mcalloc(sizeof(jmpchn)); dqinit(jmpchain,link); if (window_token == TK_EOL) return TRUE; is_commarg = last_source_column == 1; x = for_end_of_scope(0); assert(x.oprclass == INDR_REF); if (window_token == TK_SPACE) { jmpref = newtriple(OC_JMPTCLR); jmpref->operand[0] = x; nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn)); nxtjmp->jmptrip = jmpref; dqins(jmpchain,link,nxtjmp); } else { first_time = TRUE; for (;;) { ta_opr = (oprtype *) mcalloc(sizeof(oprtype)); if (!bool_expr((bool) TRUE, ta_opr)) return FALSE; if ((ref0 = curtchain->exorder.bl)->opcode == OC_JMPNEQ && (ref1 = ref0->exorder.bl)->opcode == OC_COBOOL && (ref2 = ref1->exorder.bl)->opcode == OC_INDGLVN) { dqdel(ref0,exorder); ref1->opcode = OC_JMPTSET; ref1->operand[0] = put_indr(ta_opr); ref2->opcode = OC_COMMARG; ref2->operand[1] = put_ilit((mint) indir_if); } t_set = curtchain->exorder.bl->opcode == OC_JMPTSET; if (!t_set) newtriple(OC_CLRTEST); if (expr_start != expr_start_orig) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(expr_start); } jmpref = newtriple(OC_JMP); jmpref->operand[0] = x; nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn)); nxtjmp->jmptrip = jmpref; dqins(jmpchain,link,nxtjmp); tnxtarg(ta_opr); if (first_time) { if (!t_set) newtriple(OC_SETTEST); if (expr_start != expr_start_orig) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(expr_start); } first_time = FALSE; } if (window_token != TK_COMMA) break; advancewindow(); } } if (is_commarg) { if (window_token != TK_EOL) { stx_error(ERR_INDEXTRACHARS); return FALSE; } return TRUE; } if (window_token != TK_EOL && window_token != TK_SPACE) { stx_error(ERR_SPOREOL); return FALSE; } if (!linetail()) { tnxtarg(&x); dqloop(jmpchain,link,nxtjmp) { ref1 = nxtjmp->jmptrip; ref1->operand[0] = x; }
int bool_expr(boolean_t sense, oprtype *addr) /* * invoked to resolve expresions that are by definition coerced to Boolean, which include * IF arguments, $SELECT() arguments, and postconditionals for both commands and arguments * IF is the only one that comes in with the "TRUE" sense * *addr winds up as an pointer to a jump operand, which the caller fills in */ { boolean_t is_com, tv; uint4 bexprs; opctype c; oprtype x; triple *bitrip, *t, *t0, *t1, *t2; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; INCREMENT_EXPR_DEPTH; if (!eval_expr(&x)) { DECREMENT_EXPR_DEPTH; return FALSE; } UNARY_TAIL(&x); if (OC_LIT == (x.oprval.tref)->opcode) { /* if its just a literal don't waste time */ DECREMENT_EXPR_DEPTH; return TRUE; } assert(TRIP_REF == x.oprclass); coerce(&x, OCT_BOOL); t = x.oprval.tref; for (t1 = t; ; t1 = t2) { assert(TRIP_REF == t1->operand[0].oprclass); t2 = t1->operand[0].oprval.tref; if (!(oc_tab[t2->opcode].octype & OCT_BOOL)) break; } if (OC_INDGLVN == t2->opcode) t1 = t2; /* because of how we process indirection, can't insert a NOOP between COBOOL and INDGLGN */ bitrip = maketriple(OC_BOOLINIT); /* a marker we'll delete later */ dqins(t1->exorder.bl, exorder, bitrip); assert(TREF(curtchain) == t->exorder.fl); (TREF(curtchain))->operand[0] = put_tref(bitrip); bx_tail(t, sense, addr); (TREF(curtchain))->operand[0].oprclass = NO_REF; assert(t == x.oprval.tref); DECREMENT_EXPR_DEPTH; for (bexprs = 0, t0 = t; bitrip != t0; t0 = t0->exorder.bl) { if (OCT_JUMP & oc_tab[c = t0->opcode].octype) /* WARNING assignment */ { switch (t0->opcode) { case OC_JMPFALSE: case OC_JMPTRUE: assert(INDR_REF == t0->operand[0].oprclass); t0->opcode = (OC_JMPTRUE == t0->opcode) ? OC_NOOP : OC_JMP; t0->operand[0].oprclass = (OC_NOOP == t0->opcode) ? NO_REF : INDR_REF; if (!bexprs++) t = t0; break; default: bexprs += 2; } } } bitrip->opcode = OC_NOOP; /* ditch it after it served us */ if (1 == bexprs) { /* if there is just a one JMP TRUE / FALSE turn it into a literal */ assert((OC_NOOP == t->opcode) || (OC_JMP == t->opcode)); PUT_LITERAL_TRUTH((OC_NOOP == t->opcode) ^ sense, t); t->opcode = OC_LIT; } else if (!bexprs && (OC_COBOOL == t->opcode) && (OC_LIT == (t0 = t->operand[0].oprval.tref)->opcode) && ((OC_JMPEQU == t->exorder.fl->opcode) || (OC_JMPNEQ == t->exorder.fl->opcode))) { /* just one jump based on a literal, so resolve it */ t->opcode = OC_NOOP; t->operand[0].oprclass = NO_REF; t = t->exorder.fl; dqdel(t, exorder); unuse_literal(&t0->operand[0].oprval.mlit->v); tv = (((0 == t0->operand[0].oprval.mlit->v.m[1]) ? OC_JMPNEQ : OC_JMPEQU) == t->opcode) ^ sense; PUT_LITERAL_TRUTH(tv, t0); } return TRUE; }
void bx_tail(triple *t, boolean_t sense, oprtype *addr) /* * triple *t; triple to be processed *boolean_t sense; code to be generated is jmpt or jmpf *oprtype *addr; address to jmp */ { triple *ref; oprtype *p; assert((1 & sense) == sense); assert(oc_tab[t->opcode].octype & OCT_BOOL); assert(TRIP_REF == t->operand[0].oprclass); assert((TRIP_REF == t->operand[1].oprclass) || (NOCLASS == t->operand[1].oprclass)); switch (t->opcode) { case OC_COBOOL: ex_tail(&t->operand[0]); if (OC_GETTRUTH == t->operand[0].oprval.tref->opcode) { dqdel(t->operand[0].oprval.tref, exorder); t->opcode = sense ? OC_JMPTSET : OC_JMPTCLR; t->operand[0] = put_indr(addr); return; } ref = maketriple(sense ? OC_JMPNEQ : OC_JMPEQU); ref->operand[0] = put_indr(addr); dqins(t, exorder, ref); return; case OC_COM: bx_tail(t->operand[0].oprval.tref, !sense, addr); t->opcode = OC_NOOP; t->operand[0].oprclass = 0; return; case OC_NEQU: sense = !sense; /* caution: fall through */ case OC_EQU: bx_relop(t, OC_EQU, sense ? OC_JMPNEQ : OC_JMPEQU, addr); break; case OC_NPATTERN: sense = !sense; /* caution: fall through */ case OC_PATTERN: bx_relop(t, OC_PATTERN, sense ? OC_JMPNEQ : OC_JMPEQU, addr); break; case OC_NFOLLOW: sense = !sense; /* caution: fall through */ case OC_FOLLOW: bx_relop(t, OC_FOLLOW, sense ? OC_JMPGTR : OC_JMPLEQ, addr); break; case OC_NSORTS_AFTER: sense = !sense; /* caution: fall through */ case OC_SORTS_AFTER: bx_relop(t, OC_SORTS_AFTER, sense ? OC_JMPGTR : OC_JMPLEQ, addr); break; case OC_NCONTAIN: sense = !sense; /* caution: fall through */ case OC_CONTAIN: bx_relop(t, OC_CONTAIN, sense ? OC_JMPNEQ : OC_JMPEQU, addr); break; case OC_NGT: sense = !sense; /* caution: fall through */ case OC_GT: bx_relop(t, OC_NUMCMP, sense ? OC_JMPGTR : OC_JMPLEQ, addr); break; case OC_NLT: sense = !sense; /* caution: fall through */ case OC_LT: bx_relop(t, OC_NUMCMP, sense ? OC_JMPLSS : OC_JMPGEQ, addr); break; case OC_NAND: sense = !sense; /* caution: fall through */ case OC_AND: bx_boolop(t, FALSE, sense, sense, addr); return; case OC_NOR: sense = !sense; /* caution: fall through */ case OC_OR: bx_boolop(t, TRUE, !sense, sense, addr); return; default: GTMASSERT; } for (p = t->operand ; p < ARRAYTOP(t->operand); p++) if (TRIP_REF == p->oprclass) ex_tail(p); return; }