void bx_relop(triple *t, opctype cmp, opctype tst, oprtype *addr) { triple *ref; ref = maketriple(tst); ref->operand[0] = put_indr(addr); dqins(t, exorder, ref); t->opcode = cmp; return; }
void bx_relop(triple *t, opctype cmp, opctype tst, oprtype *addr) /* work Boolean relational arguments * *t points to the Boolean operation * cmp and tst give (respectively) the opcode and the associated jump * *addr points the operand for the jump and is eventually used by logic back in the invocation stack to fill in a target location */ { triple *ref; ref = maketriple(tst); ref->operand[0] = put_indr(addr); dqins(t, exorder, ref); t->opcode = cmp; 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_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 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_get(oprtype *a, opctype op) { triple tmpchain, *oldchain, *r, *triptr; triple *jmp_to_get, *ret_get_val; oprtype result, *result_ptr; error_def(ERR_VAREXPECTED); result_ptr = (oprtype *)mcalloc(sizeof(oprtype)); result = put_indr(result_ptr); jmp_to_get = maketriple(op); ret_get_val = maketriple(op); r = maketriple(op); switch (window_token) { case TK_IDENT: if (!lvn(&r->operand[0], OC_SRCHINDX, 0)) return FALSE; if (window_token != TK_COMMA) { ins_triple(r); *a = put_tref(r); return TRUE; } r->opcode = OC_FNGET2; r->operand[1] = result; break; case TK_CIRCUMFLEX: r->opcode = OC_FNGVGET1; if (!gvn()) return FALSE; ins_triple(r); jmp_to_get->opcode = OC_JMPNEQ; jmp_to_get->operand[0] = put_tjmp(ret_get_val); ins_triple(jmp_to_get); ret_get_val->opcode = OC_FNGVGET2; ret_get_val->operand[0] = put_tref(r); ret_get_val->operand[1] = result; if (window_token != TK_COMMA) *result_ptr = put_str(0,0); else { advancewindow(); if (!expr(result_ptr)) return FALSE; } ins_triple(ret_get_val); *a = put_tref(ret_get_val); return TRUE; break; case TK_ATSIGN: r->opcode = OC_INDGET; if (shift_gvrefs) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!indirection(&r->operand[0])) { setcurtchain(oldchain); return FALSE; } r->operand[1] = result; if (window_token == TK_COMMA) { advancewindow(); if (!expr(result_ptr)) return FALSE; } else *result_ptr = put_str(0, 0); ins_triple(r); newtriple(OC_GVSAVTARG); setcurtchain(oldchain); dqadd(expr_start, &tmpchain, exorder); expr_start = tmpchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(expr_start); *a = put_tref(r); return TRUE; } if (!indirection(&r->operand[0])) return FALSE; r->operand[1] = result; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } if (window_token == TK_COMMA) { advancewindow(); if (!expr(result_ptr)) return FALSE; } else *result_ptr = put_str(0, 0); ins_triple(r); *a = put_tref(r); return TRUE; }
int f_get(oprtype *a, opctype op) { triple *oldchain, *r, tmpchain, *triptr; oprtype result, *result_ptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; result_ptr = (oprtype *)mcalloc(SIZEOF(oprtype)); result = put_indr(result_ptr); r = maketriple(op); switch (TREF(window_token)) { case TK_IDENT: if (!lvn(&r->operand[0], OC_SRCHINDX, 0)) return FALSE; if (TK_COMMA != TREF(window_token)) { ins_triple(r); *a = put_tref(r); return TRUE; } r->opcode = OC_FNGET2; r->operand[1] = result; break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; if (TK_COMMA == TREF(window_token)) { /* 2-argument $GET with global-variable as first argument. In this case generate the following * sequence of opcodes. OC_FNGVGET1, opcodes-to-evaluate-second-argument-expression, OC_FNGVGET2 */ r->opcode = OC_FNGVGET1; ins_triple(r); triptr = r; /* Prepare triple for OC_FNGVGET2 */ r = maketriple(op); r->opcode = OC_FNGVGET2; r->operand[0] = put_tref(triptr); r->operand[1] = result; } else { r->opcode = OC_FNGVGET; r->operand[0] = result; } break; case TK_ATSIGN: r->opcode = OC_INDGET; 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] = result; if (TK_COMMA == TREF(window_token)) { advancewindow(); if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR)) return FALSE; } else *result_ptr = put_str(0, 0); 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)); *a = put_tref(r); return TRUE; } if (!indirection(&r->operand[0])) return FALSE; r->operand[1] = result; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } if (TK_COMMA == TREF(window_token)) { advancewindow(); if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR)) return FALSE; } else *result_ptr = put_str(0, 0); ins_triple(r); *a = put_tref(r); return TRUE; }
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; }
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; }