triple *maketriple(opctype op) { triple *x; x = (triple *)mcalloc(SIZEOF(triple)); x->opcode = op; x->src.line = source_line; x->src.column = source_column; dqinit(&(x->backptr), que); dqinit(&(x->jmplist), que); return x; }
int m_xecute(void) { oprtype *cr, x; triple *obp, *oldchain, *ref0, *ref1, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; dqinit(&tmpchain,exorder); oldchain = setcurtchain(&tmpchain); switch (expr(&x, MUMPS_STR)) { case EXPR_FAIL: setcurtchain(oldchain); return FALSE; case EXPR_INDR: if (TK_COLON != TREF(window_token)) { make_commarg(&x,indir_xecute); break; } /* caution: fall through */ case EXPR_GOOD: ref0 = maketriple(OC_COMMARG); ref0->operand[0] = x; ref0->operand[1] = put_ilit(indir_linetail); ins_triple(ref0); } setcurtchain(oldchain); if (TK_COLON == TREF(window_token)) { advancewindow(); cr = (oprtype *)mcalloc(SIZEOF(oprtype)); if (!bool_expr(FALSE, cr)) return FALSE; if (TREF(expr_start) != TREF(expr_start_orig)) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } obp = oldchain->exorder.bl; dqadd(obp,&tmpchain,exorder); /* violates info hiding */ if (TREF(expr_start) != TREF(expr_start_orig)) { ref0 = newtriple(OC_JMP); ref1 = newtriple(OC_GVRECTARG); ref1->operand[0] = put_tref(TREF(expr_start)); *cr = put_tjmp(ref1); tnxtarg(&ref0->operand[0]); } else tnxtarg(cr); return TRUE; } obp = oldchain->exorder.bl; dqadd(obp,&tmpchain,exorder); /* violates info hiding */ return TRUE; }
int f_data(oprtype *a, opctype op) { triple *oldchain, *r, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; assert(OC_FNDATA == op || OC_FNZDATA == op); r = maketriple(op); switch (TREF(window_token)) { case TK_IDENT: if (!lvn(&(r->operand[0]), OC_SRCHINDX, 0)) return FALSE; ins_triple(r); break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; r->opcode = OC_GVDATA; ins_triple(r); break; case TK_ATSIGN: TREF(saw_side_effect) = TREF(shift_side_effects); if (TREF(shift_side_effects) && (GTM_BOOL == TREF(gtm_fullbool))) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!indirection(&(r->operand[0]))) { setcurtchain(oldchain); return FALSE; } r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata)); ins_triple(r); newtriple(OC_GVSAVTARG); setcurtchain(oldchain); dqadd(TREF(expr_start), &tmpchain, exorder); TREF(expr_start) = tmpchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } else { if (!indirection(&(r->operand[0]))) return FALSE; r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata)); ins_triple(r); } r->opcode = OC_INDFUN; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } *a = put_tref(r); return TRUE; }
void ufs_init() { static int done = 0; if (done) return; done = 1; ufs_ihashinit(); #ifdef QUOTA dqinit(); #endif return; }
int ufs_init() { static int first = 1; if (!first) return (0); first = 0; #ifdef DIAGNOSTIC if ((sizeof(struct inode) - 1) & sizeof(struct inode)) printf("ufs_init: bad size %d\n", sizeof(struct inode)); #endif ufs_ihashinit(); dqinit(); return (0); }
int m_goto(void) { oprtype *cr; triple *obp, *oldchain, *ref0, *ref1, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!entryref(OC_JMP, OC_EXTJMP, (mint)indir_goto, TRUE, FALSE, FALSE)) { setcurtchain(oldchain); return FALSE; } setcurtchain(oldchain); if (TK_COLON == TREF(window_token)) { advancewindow(); cr = (oprtype *)mcalloc(SIZEOF(oprtype)); if (!bool_expr(FALSE, cr)) return FALSE; if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode)) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode)) { ref0 = newtriple(OC_JMP); ref1 = newtriple(OC_GVRECTARG); ref1->operand[0] = put_tref(TREF(expr_start)); *cr = put_tjmp(ref1); tnxtarg(&ref0->operand[0]); } else tnxtarg(cr); return TRUE; } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ return TRUE; }
int m_goto(void) { triple tmpchain, *oldchain, *obp, *ref0, *ref1, *triptr; oprtype *cr; dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!entryref(OC_JMP, OC_EXTJMP, (mint) indir_goto, TRUE, FALSE)) { setcurtchain(oldchain); return FALSE; } setcurtchain(oldchain); if (window_token == TK_COLON) { advancewindow(); cr = (oprtype *) mcalloc(sizeof(oprtype)); if (!bool_expr((bool) FALSE, cr)) return FALSE; if (expr_start != expr_start_orig) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(expr_start); } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if (expr_start != expr_start_orig) { ref0 = newtriple(OC_JMP); ref1 = newtriple(OC_GVRECTARG); ref1->operand[0] = put_tref(expr_start); *cr = put_tjmp(ref1); tnxtarg(&ref0->operand[0]); } else tnxtarg(cr); return TRUE; } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ return TRUE; }
/* * Initialize UFS filesystems, done only once. */ void ufs_init(void) { if (ufs_initcount++ > 0) return; ufs_direct_cache = pool_cache_init(sizeof(struct direct), 0, 0, 0, "ufsdir", NULL, IPL_NONE, NULL, NULL, NULL); ufs_ihashinit(); #ifdef QUOTA dqinit(); #endif #ifdef UFS_DIRHASH ufsdirhash_init(); #endif #ifdef UFS_EXTATTR ufs_extattr_init(); #endif }
int gvn(void) { triple *ref, *t1, *oldchain, tmpchain, *triptr, *s; oprtype subscripts[MAX_GVSUBSCRIPTS], *sb1, *sb2; boolean_t shifting, vbar, parse_status; opctype ox; char x; error_def(ERR_MAXNRSUBSCRIPTS); error_def(ERR_RPARENMISSING); error_def(ERR_GBLNAME); error_def(ERR_EXTGBLDEL); error_def(ERR_GVNAKEDEXTNM); error_def(ERR_EXPR); DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; assert(window_token == TK_CIRCUMFLEX); advancewindow(); sb1 = sb2 = subscripts; ox = 0; if (shifting = TREF(shift_side_effects)) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); } if (window_token == TK_LBRACKET || window_token == TK_VBAR) { vbar = (window_token == TK_VBAR); advancewindow(); if (vbar) parse_status = expr(sb1++); else parse_status = expratom(sb1++); if (!parse_status) { stx_error(ERR_EXPR); if (shifting) setcurtchain(oldchain); return FALSE; } if (window_token == TK_COMMA) { advancewindow(); if (vbar) parse_status = expr(sb1++); else parse_status = expratom(sb1++); if (!parse_status) { stx_error(ERR_EXPR); if (shifting) setcurtchain(oldchain); return FALSE; } } else *sb1++ = put_str(0,0); if ((!vbar && window_token != TK_RBRACKET) || (vbar && window_token != TK_VBAR)) { stx_error(ERR_EXTGBLDEL); if (shifting) setcurtchain(oldchain); return FALSE; } advancewindow(); ox = OC_GVEXTNAM; } if (window_token == TK_IDENT) { if (!ox) ox = OC_GVNAME; *sb1++ = put_str(window_ident.addr, window_ident.len); advancewindow(); } else { if (ox) { stx_error(ERR_GVNAKEDEXTNM); if (shifting) setcurtchain(oldchain); return FALSE; } if (window_token != TK_LPAREN) { stx_error(ERR_GBLNAME); if (shifting) setcurtchain(oldchain); return FALSE; } ox = OC_GVNAKED; } if (window_token == TK_LPAREN) for (;;) { if (sb1 >= ARRAYTOP(subscripts)) { stx_error(ERR_MAXNRSUBSCRIPTS); if (shifting) setcurtchain(oldchain); return FALSE; } advancewindow(); if (!expr(sb1)) { if (shifting) setcurtchain(oldchain); return FALSE; } assert(sb1->oprclass == TRIP_REF); s = sb1->oprval.tref; if (s->opcode == OC_LIT) *sb1 = make_gvsubsc(&s->operand[0].oprval.mlit->v); sb1++; if ((x = window_token) == TK_RPAREN) { advancewindow(); break; } if (x != TK_COMMA) { stx_error(ERR_RPARENMISSING); if (shifting) setcurtchain(oldchain); return FALSE; } } ref = newtriple(ox); ref->operand[0] = put_ilit((mint)(sb1 - sb2)); for ( ; sb2 < sb1 ; sb2++) { t1 = newtriple(OC_PARAMETER); ref->operand[1] = put_tref(t1); ref = t1; ref->operand[0] = *sb2; } if (shifting) { 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)); } 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 f_select(oprtype *a, opctype op) { boolean_t first_time, save_saw_side, save_shift; unsigned int save_depth; opctype old_op; oprtype *cnd, endtrip, target, tmparg; triple *oldchain, *r, *ref, *save_start, *save_start_orig, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; save_shift = TREF(shift_side_effects); save_saw_side = TREF(saw_side_effect); save_depth = TREF(expr_depth); save_start = TREF(expr_start); save_start_orig = TREF(expr_start_orig); TREF(shift_side_effects) = FALSE; TREF(saw_side_effect) = FALSE; TREF(expr_depth) = 0; TREF(expr_start) = TREF(expr_start_orig) = NULL; if (save_shift) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); } r = maketriple(op); first_time = TRUE; endtrip = put_tjmp(r); for (;;) { cnd = (oprtype *)mcalloc(SIZEOF(oprtype)); if (!bool_expr(FALSE, cnd)) { if (save_shift) setcurtchain(oldchain); return FALSE; } if (TK_COLON != TREF(window_token)) { if (save_shift) setcurtchain(oldchain); stx_error(ERR_COLON); return FALSE; } advancewindow(); if (EXPR_FAIL == expr(&tmparg, MUMPS_EXPR)) { if (save_shift) setcurtchain(oldchain); return FALSE; } assert(TRIP_REF == tmparg.oprclass); old_op = tmparg.oprval.tref->opcode; if (first_time) { if ((OC_LIT == old_op) || (oc_tab[old_op].octype & OCT_MVADDR)) { ref = newtriple(OC_STOTEMP); ref->operand[0] = tmparg; tmparg = put_tref(ref); } r->operand[0] = target = tmparg; first_time = FALSE; } else { ref = newtriple(OC_STO); ref->operand[0] = target; ref->operand[1] = tmparg; if (OC_PASSTHRU == tmparg.oprval.tref->opcode) { assert(TRIP_REF == tmparg.oprval.tref->operand[0].oprclass); ref = newtriple(OC_STO); ref->operand[0] = target; ref->operand[1] = put_tref(tmparg.oprval.tref->operand[0].oprval.tref); } } ref = newtriple(OC_JMP); ref->operand[0] = endtrip; tnxtarg(cnd); if (TK_COMMA != TREF(window_token)) break; advancewindow(); } tmparg = put_ilit(ERR_SELECTFALSE); ref = newtriple(OC_RTERROR); ref->operand[0] = tmparg; ref->operand[1] = put_ilit(FALSE); /* Not a subroutine reference */ ins_triple(r); assert(!TREF(expr_depth)); TREF(shift_side_effects) = save_shift; TREF(saw_side_effect) = save_saw_side; TREF(expr_depth) = save_depth; TREF(expr_start) = save_start; TREF(expr_start_orig) = save_start_orig; if (save_shift) { 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; }
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_zgoto(void) { triple tmpchain, *oldchain, *obp, *ref0, *ref1, *triptr; oprtype *cr, quits; int4 rval; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if ((TK_EOL == window_token) || (TK_SPACE == window_token)) { /* Default zgoto level is 1 */ quits = put_ilit(1); rval = EXPR_GOOD; } else if (!(rval = intexpr(&quits))) /* note assignment */ { setcurtchain(oldchain); return FALSE; } if ((EXPR_INDR != rval) && ((TK_EOL == window_token) || (TK_SPACE == window_token))) { /* Only level parm supplied (no entry ref) - job for op_zg1 */ setcurtchain(oldchain); obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */ ref0 = newtriple(OC_ZG1); ref0->operand[0] = quits; return TRUE; } if (TK_COLON != window_token) { /* First arg parsed, not ending in ":". Better have been indirect */ setcurtchain(oldchain); if (EXPR_INDR != rval) { stx_error(ERR_COLON); return FALSE; } make_commarg(&quits, indir_zgoto); obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */ return TRUE; } advancewindow(); if (TK_COLON != window_token) { if (!entryref(OC_NOOP, OC_PARAMETER, (mint)indir_goto, FALSE, FALSE, TRUE)) { setcurtchain(oldchain); return FALSE; } ref0 = maketriple(OC_ZGOTO); ref0->operand[0] = quits; ref0->operand[1] = put_tref(tmpchain.exorder.bl); ins_triple(ref0); setcurtchain(oldchain); } else { ref0 = maketriple(OC_ZG1); ref0->operand[0] = quits; ins_triple(ref0); setcurtchain(oldchain); } if (TK_COLON == window_token) { /* post conditional expression */ advancewindow(); cr = (oprtype *)mcalloc(SIZEOF(oprtype)); if (!bool_expr((bool)FALSE, cr)) return FALSE; if (TREF(expr_start) != TREF(expr_start_orig)) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */ if (TREF(expr_start) != TREF(expr_start_orig)) { ref0 = newtriple(OC_JMP); ref1 = newtriple(OC_GVRECTARG); ref1->operand[0] = put_tref(TREF(expr_start)); *cr = put_tjmp(ref1); tnxtarg(&ref0->operand[0]); } else tnxtarg(cr); return TRUE; } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */ 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; }
int f_order1( oprtype *a, opctype op) { triple *oldchain, tmpchain, *r, *triptr; error_def(ERR_VAREXPECTED); DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); switch (window_token) { case TK_IDENT: if (director_token != TK_LPAREN) { r->opcode = OC_FNLVNAME; r->operand[0] = put_str(window_ident.addr, window_ident.len); r->operand[1] = put_ilit(0); /* FALSE - do not return aliased vars with no value */ ins_triple(r); advancewindow(); break; } if (!lvn(&(r->operand[0]), OC_SRCHINDX, r)) return FALSE; ins_triple(r); break; case TK_CIRCUMFLEX: if (!gvn()) return FALSE; r->opcode = OC_GVORDER; ins_triple(r); break; case TK_ATSIGN: if (TREF(shift_side_effects)) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!indirection(&(r->operand[0]))) { setcurtchain(oldchain); return FALSE; } r->operand[1] = put_ilit((mint)indir_fnorder1); ins_triple(r); newtriple(OC_GVSAVTARG); setcurtchain(oldchain); dqadd(TREF(expr_start), &tmpchain, exorder); TREF(expr_start) = tmpchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } else { if (!indirection(&(r->operand[0]))) return FALSE; r->operand[1] = put_ilit((mint)indir_fnorder1); ins_triple(r); } r->opcode = OC_INDFUN; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } *a = put_tref(r); return TRUE; }
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 exfunc(oprtype *a, boolean_t alias_target) { triple *calltrip, *calltrip_opr1_tref, *counttrip, *funret, *labelref, *masktrip; triple *oldchain, *ref0, *routineref, tmpchain, *triptr; # if defined(USHBIN_SUPPORTED) || defined(VMS) triple *tripsize; # endif assert(TK_DOLLAR == window_token); advancewindow(); dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); calltrip = entryref(OC_EXFUN, OC_EXTEXFUN, INDIR_DUMMY, TRUE, TRUE, FALSE); setcurtchain(oldchain); if (!calltrip) return FALSE; if (OC_EXFUN == calltrip->opcode) { assert(MLAB_REF == calltrip->operand[0].oprclass); # if defined(USHBIN_SUPPORTED) || defined(VMS) ref0 = newtriple(OC_PARAMETER); ref0->operand[0] = put_tsiz(); /* Need size of following code gen triple here */ calltrip->operand[1] = put_tref(ref0); tripsize = ref0->operand[0].oprval.tref; assert(OC_TRIPSIZE == tripsize->opcode); # else ref0 = calltrip; # endif } else { calltrip_opr1_tref = calltrip->operand[1].oprval.tref; if (OC_EXTEXFUN == calltrip->opcode) { assert(TRIP_REF == calltrip->operand[1].oprclass); if (OC_CDLIT == calltrip_opr1_tref->opcode) assert(CDLT_REF == calltrip_opr1_tref->operand[0].oprclass); else { assert(OC_LABADDR == calltrip_opr1_tref->opcode); assert(TRIP_REF == calltrip_opr1_tref->operand[1].oprclass); assert(OC_PARAMETER == calltrip_opr1_tref->operand[1].oprval.tref->opcode); assert(TRIP_REF == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprclass); assert(OC_ILIT == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->opcode); assert(ILIT_REF == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprclass); if (0 != calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprval.ilit) { stx_error(ERR_ACTOFFSET); return FALSE; } } } else /* $$ @dlabel [actuallist] */ { assert(OC_COMMARG == calltrip->opcode); assert(TRIP_REF == calltrip->operand[1].oprclass); assert(OC_ILIT == calltrip_opr1_tref->opcode); assert(ILIT_REF == calltrip_opr1_tref->operand[0].oprclass); assert(INDIR_DUMMY == calltrip_opr1_tref->operand[0].oprval.ilit); assert(calltrip->exorder.fl == &tmpchain); routineref = maketriple(OC_CURRHD); labelref = maketriple(OC_LABADDR); ref0 = maketriple(OC_PARAMETER); dqins(calltrip->exorder.bl, exorder, routineref); dqins(calltrip->exorder.bl, exorder, labelref); dqins(calltrip->exorder.bl, exorder, ref0); labelref->operand[0] = calltrip->operand[0]; labelref->operand[1] = put_tref(ref0); ref0->operand[0] = calltrip->operand[1]; ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0; ref0->operand[1] = put_tref(routineref); calltrip->operand[0] = put_tref(routineref); calltrip->operand[1] = put_tref(labelref); calltrip->opcode = OC_EXTEXFUN; } ref0 = newtriple(OC_PARAMETER); ref0->operand[0] = calltrip->operand[1]; calltrip->operand[1] = put_tref(ref0); } if (TK_LPAREN != window_token) { masktrip = newtriple(OC_PARAMETER); counttrip = newtriple(OC_PARAMETER); masktrip->operand[0] = put_ilit(0); counttrip->operand[0] = put_ilit(0); masktrip->operand[1] = put_tref(counttrip); ref0->operand[1] = put_tref(masktrip); } else if (!actuallist(&ref0->operand[1])) return FALSE; triptr = oldchain->exorder.bl; dqadd(triptr, &tmpchain, exorder); /*this is a violation of info hiding*/ if (OC_EXFUN == calltrip->opcode) { assert(MLAB_REF == calltrip->operand[0].oprclass); triptr = newtriple(OC_JMP); triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname); calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */ # if defined(USHBIN_SUPPORTED) || defined(VMS) tripsize->operand[0].oprval.tsize->ct = triptr; # endif } /* If target is an alias, use special container-expecting routine OC_EXFUNRETALS, else regular OC_EXFUNRET */ funret = newtriple((alias_target ? OC_EXFUNRETALS : OC_EXFUNRET)); funret->operand[0] = *a = put_tref(calltrip); return TRUE; }
int m_do(void) { triple tmpchain, *oldchain, *obp, *ref0, *tripsize, *triptr, *ref1, *calltrip, *routineref, *labelref; oprtype *cr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; if ((TK_SPACE == window_token) || (TK_EOL == window_token)) { if (!run_time) /* DO SP SP is a noop at run time */ { calltrip = newtriple(OC_CALLSP); calltrip->operand[0] = put_mnxl(); calltrip->operand[1] = put_ocnt(); } return TRUE; } else if (TK_AMPERSAND == window_token) { if (!extern_func(0)) return FALSE; else return TRUE; } dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE); setcurtchain(oldchain); if (!calltrip) return FALSE; if (TK_LPAREN == window_token) { if (OC_CALL == calltrip->opcode) { assert(MLAB_REF == calltrip->operand[0].oprclass); calltrip->opcode = OC_EXCAL; ref0 = newtriple(OC_PARAMETER); calltrip->operand[1] = put_tref(ref0); ref0->operand[0] = put_tsiz(); /* parm to hold size of jump codegen */ tripsize = ref0->operand[0].oprval.tref; assert(OC_TRIPSIZE == tripsize->opcode); } else { if (OC_EXTCALL == calltrip->opcode) { assert(TRIP_REF == calltrip->operand[1].oprclass); if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode) assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass); else { assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode); assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass); assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode); assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass); assert(OC_ILIT == calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->opcode); assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->operand[0].oprclass); if (0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->operand[0].oprval.ilit) { stx_error(ERR_ACTOFFSET); return FALSE; } } } else /* DO _ @dlabel actuallist */ { assert(OC_COMMARG == calltrip->opcode); assert(TRIP_REF == calltrip->operand[1].oprclass); assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode); assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass); assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit); assert(calltrip->exorder.fl == &tmpchain); routineref = maketriple(OC_CURRHD); labelref = maketriple(OC_LABADDR); ref0 = maketriple(OC_PARAMETER); dqins(calltrip->exorder.bl, exorder, routineref); dqins(calltrip->exorder.bl, exorder, labelref); dqins(calltrip->exorder.bl, exorder, ref0); labelref->operand[0] = calltrip->operand[0]; labelref->operand[1] = put_tref(ref0); ref0->operand[0] = calltrip->operand[1]; ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0; ref0->operand[1] = put_tref(routineref); calltrip->operand[0] = put_tref(routineref); calltrip->operand[1] = put_tref(labelref); } calltrip->opcode = OC_EXTEXCAL; ref0 = newtriple(OC_PARAMETER); ref0->operand[0] = calltrip->operand[1]; calltrip->operand[1] = put_tref(ref0); } if (!actuallist(&ref0->operand[1])) return FALSE; } else if (OC_CALL == calltrip->opcode) { calltrip->operand[1] = put_ocnt(); if (TREF(for_stack_ptr) != TADR(for_stack)) { if (TAREF1(for_temps, (TREF(for_stack_ptr) - TADR(for_stack)))) calltrip->opcode = OC_FORLCLDO; } } if (TK_COLON == window_token) { advancewindow(); cr = (oprtype *)mcalloc(SIZEOF(oprtype)); if (!bool_expr((bool) FALSE, cr)) return FALSE; if (TREF(expr_start) != TREF(expr_start_orig)) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if (OC_EXCAL == calltrip->opcode) { triptr = newtriple(OC_JMP); triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname); calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */ tripsize->operand[0].oprval.tsize->ct = triptr; } if (TREF(expr_start) != TREF(expr_start_orig)) { ref0 = newtriple(OC_JMP); ref1 = newtriple(OC_GVRECTARG); ref1->operand[0] = put_tref(TREF(expr_start)); *cr = put_tjmp(ref1); tnxtarg(&ref0->operand[0]); } else tnxtarg(cr); } else { obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if (OC_EXCAL == calltrip->opcode) { triptr = newtriple(OC_JMP); triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname); calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */ tripsize->operand[0].oprval.tsize->ct = triptr; } } return 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; }
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_do(void) { int opcd; oprtype *cr; triple *calltrip, *labelref, *obp, *oldchain, *ref0, *ref1, *routineref, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; if ((TK_EOL == TREF(window_token)) || (TK_SPACE == TREF(window_token))) { if (!run_time) /* DO SP SP is a noop at run time */ { calltrip = newtriple(OC_CALLSP); calltrip->operand[0] = put_mnxl(); } return TRUE; } else if (TK_AMPERSAND == TREF(window_token)) { if (!extern_func(0)) return FALSE; else return TRUE; } dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE); setcurtchain(oldchain); if (!calltrip) return FALSE; if (TK_LPAREN == TREF(window_token)) { if (OC_CALL == calltrip->opcode) { assert(MLAB_REF == calltrip->operand[0].oprclass); calltrip->opcode = OC_EXCAL; ref0 = calltrip; } else { if (OC_EXTCALL == calltrip->opcode) { assert(TRIP_REF == calltrip->operand[1].oprclass); if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode) assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass); else { assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode); assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass); assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode); assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass); DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->opcode); assert((OC_ILIT == opcd) || (OC_COMINT == opcd)); DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->operand[0].oprclass); assert((ILIT_REF == opcd) || (TRIP_REF == opcd)); /* The opcd references above added to allow an invalid syntax using indirect values for * offsets while specifying a parm list to get through the above asserts (invalid syntax * should not trip asserts) but it leads to the conclusion that the below test may not be * robust enough since it is looking at a literal integer value when there is none so have * added further checks mirroring the first checks done in the two most recent asserts to * make the check more robust. [Example bad code: Do @lbl+@n^artn(arg)] */ if ((0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->operand[0].oprval.ilit) || (OC_ILIT != calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->opcode) || (ILIT_REF != calltrip->operand[1].oprval.tref->operand[1].oprval.tref-> operand[0].oprval.tref->operand[0].oprclass)) { stx_error (ERR_ACTOFFSET); return FALSE; } } } else { /* DO _ @dlabel actuallist */ assert(OC_COMMARG == calltrip->opcode); assert(TRIP_REF == calltrip->operand[1].oprclass); assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode); assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass); assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit); assert(calltrip->exorder.fl == &tmpchain); routineref = maketriple(OC_CURRHD); labelref = maketriple(OC_LABADDR); ref0 = maketriple(OC_PARAMETER); dqins(calltrip->exorder.bl, exorder, routineref); dqins(calltrip->exorder.bl, exorder, labelref); dqins(calltrip->exorder.bl, exorder, ref0); labelref->operand[0] = calltrip->operand[0]; labelref->operand[1] = put_tref (ref0); ref0->operand[0] = calltrip->operand[1]; ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0; ref0->operand[1] = put_tref (routineref); calltrip->operand[0] = put_tref(routineref); calltrip->operand[1] = put_tref(labelref); } calltrip->opcode = OC_EXTEXCAL; ref0 = newtriple(OC_PARAMETER); ref0->operand[0] = calltrip->operand[1]; calltrip->operand[1] = put_tref(ref0); } if (!actuallist(&ref0->operand[1])) return FALSE; } else if (OC_CALL == calltrip->opcode) { if (TREF(for_stack_ptr) != (oprtype **)TADR(for_stack)) { if (TAREF1(for_temps, (TREF(for_stack_ptr) - (oprtype **)TADR(for_stack)))) calltrip->opcode = OC_FORLCLDO; } } if (TK_COLON == TREF(window_token)) { advancewindow(); cr = (oprtype *)mcalloc(SIZEOF(oprtype)); if (!bool_expr(FALSE, cr)) return FALSE; if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode)) { triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if (calltrip->opcode == OC_EXCAL) { triptr = newtriple(OC_JMP); triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname); calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */ } if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode)) { ref0 = newtriple(OC_JMP); ref1 = newtriple(OC_GVRECTARG); ref1->operand[0] = put_tref(TREF(expr_start)); *cr = put_tjmp(ref1); tnxtarg(&ref0->operand[0]); } else tnxtarg(cr); } else { obp = oldchain->exorder.bl; dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if (OC_EXCAL == calltrip->opcode) { triptr = newtriple(OC_JMP); triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname); calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */ } } return TRUE; }
int f_incr(oprtype *a, opctype op) { boolean_t ok; oprtype *increment; triple incrchain, *oldchain, *r, *savptr, targchain, tmpexpr, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); /* may need to evaluate the increment (2nd arg) early and use result later: prepare to juggle triple chains */ dqinit(&targchain, exorder); /* a place for the operation and the target */ dqinit(&tmpexpr, exorder); /* a place to juggle the shifted chain in case it's active */ triptr = TREF(expr_start); savptr = TREF(expr_start_orig); /* but make sure expr_start_orig == expr_start since this is a new chain */ TREF(expr_start_orig) = TREF(expr_start) = &tmpexpr; oldchain = setcurtchain(&targchain); /* save the result of the first argument 'cause it evaluates 2nd */ switch (TREF(window_token)) { case TK_IDENT: /* $INCREMENT() performs an implicit $GET() on a first argument lvn so we use OC_PUTINDX because * we know only at runtime whether to signal an UNDEF error (depending on whether we have * VIEW "NOUNDEF" or "UNDEF" state; op_putindx creates the local variable unconditionally, even if * we have "UNDEF" state, in which case any error in op_fnincr causes an op_kill of that local variable */ ok = (lvn(&(r->operand[0]), OC_PUTINDX, 0)); break; case TK_CIRCUMFLEX: ok = gvn(); r->opcode = OC_GVINCR; r->operand[0] = put_ilit(0); /* dummy fill since emit_code does not like empty operand[0] */ break; case TK_ATSIGN: ok = indirection(&r->operand[0]); r->opcode = OC_INDINCR; break; default: ok = FALSE; break; } if (!ok) { setcurtchain(oldchain); return FALSE; } TREF(expr_start) = triptr; /* restore original shift chain */ TREF(expr_start_orig) = savptr; increment = &r->operand[1]; if (TK_COMMA != TREF(window_token)) *increment = put_ilit(1); /* default optional increment to 1 */ else { dqinit(&incrchain, exorder); /* a place for the increment */ setcurtchain(&incrchain); /* increment expr must evaluate before the glvn in $INCR(glvn,expr) */ advancewindow(); if (EXPR_FAIL == expr(increment, MUMPS_NUM)) { setcurtchain(oldchain); return FALSE; } dqadd(&targchain, &incrchain, exorder); /* dir before targ - this is a violation of info hiding */ setcurtchain(&targchain); } coerce(increment, OCT_MVAL); ins_triple(r); if (&tmpexpr != tmpexpr.exorder.bl) { /* one or more OC_GVNAME may have shifted so add to the end of the shift chain */ assert(TREF(shift_side_effects)); dqadd(TREF(expr_start), &tmpexpr, exorder); /* this is a violation of info hiding */ TREF(expr_start) = tmpexpr.exorder.bl; assert(OC_GVSAVTARG == (TREF(expr_start))->opcode); triptr = newtriple(OC_GVRECTARG); /* restore the result of the last gvn to preserve $referece (the naked) */ triptr->operand[0] = put_tref(TREF(expr_start)); } if (!TREF(shift_side_effects) || (GTM_BOOL != TREF(gtm_fullbool)) || (OC_INDINCR != r->opcode)) { /* put it on the end of the main chain as there's no reason to play more with the ordering */ setcurtchain(oldchain); triptr = (TREF(curtchain))->exorder.bl; dqadd(triptr, &targchain, exorder); /* this is a violation of info hiding */ } else /* need full side effects or indirect 1st argument so put everything on the shift chain */ { /* add the chain after "expr_start" which may be much before "curtchain" */ newtriple(OC_GVSAVTARG); setcurtchain(oldchain); assert(NULL != TREF(expr_start)); dqadd(TREF(expr_start), &targchain, exorder); /* this is a violation of info hiding */ TREF(expr_start) = targchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } /* $increment() args need to avoid side effect processing but that's handled in expritem so eval_expr gets $i()'s SE flag */ *a = put_tref(r); return TRUE; }
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 compile_pattern(oprtype *opr, bool is_indirect) { ptstr retstr; mval retmval; mstr instr; int status; triple *oldchain, tmpchain, *ref, *triptr; if (is_indirect) { if (shift_gvrefs) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!indirection(opr)) { setcurtchain(oldchain); return FALSE; } ref = newtriple(OC_INDPAT); 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); } else { if (!indirection(opr)) return FALSE; ref = newtriple(OC_INDPAT); } ref->operand[0] = *opr; *opr = put_tref(ref); return TRUE; } else { instr.addr = (char *)&source_buffer[source_column - 1]; instr.len = strlen(instr.addr); status = patstr(&instr, &retstr, NULL); last_source_column = (short int)(instr.addr - (char *)source_buffer); assert(last_source_column); if (status) { /* status == syntax error when non-zero */ stx_error(status); return FALSE; } retmval.mvtype = MV_STR; retmval.str.len = retstr.len * sizeof(uint4); retmval.str.addr = stringpool.free; if (stringpool.top - stringpool.free < retmval.str.len) stp_gcol(retmval.str.len); memcpy(stringpool.free, &retstr.buff[0], retmval.str.len); stringpool.free += retmval.str.len; *opr = put_lit(&retmval); lexical_ptr = (char *)&source_buffer[last_source_column - 1]; advancewindow(); advancewindow(); return TRUE; } }
int f_next( oprtype *a, opctype op) { triple *oldchain, tmpchain, *ref, *r, *triptr; error_def(ERR_VAREXPECTED); error_def(ERR_LVORDERARG); error_def(ERR_GVNEXTARG); DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; r = maketriple(op); switch (window_token) { case TK_IDENT: if (director_token != TK_LPAREN) { stx_error(ERR_LVORDERARG); return FALSE; } if (!lvn(&(r->operand[0]),OC_SRCHINDX,r)) return FALSE; ins_triple(r); break; case TK_CIRCUMFLEX: ref = TREF(shift_side_effects) ? TREF(expr_start) : curtchain->exorder.bl; if (!gvn()) return FALSE; /* the following assumes OC_LIT and OC_GVNAME are all one * gets for an unsubscripted global variable reference */ if ((TREF(shift_side_effects) ? TREF(expr_start) : curtchain)->exorder.bl->exorder.bl->exorder.bl == ref) { stx_error(ERR_GVNEXTARG); return FALSE; } r->opcode = OC_GVNEXT; ins_triple(r); break; case TK_ATSIGN: if (TREF(shift_side_effects)) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (!indirection(&(r->operand[0]))) { setcurtchain(oldchain); return FALSE; } r->operand[1] = put_ilit((mint)indir_fnnext); ins_triple(r); newtriple(OC_GVSAVTARG); setcurtchain(oldchain); dqadd(TREF(expr_start), &tmpchain, exorder); TREF(expr_start) = tmpchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } else { if (!indirection(&(r->operand[0]))) return FALSE; r->operand[1] = put_ilit((mint)indir_fnnext); ins_triple(r); } r->opcode = OC_INDFUN; break; default: stx_error(ERR_VAREXPECTED); return FALSE; } *a = put_tref(r); return TRUE; }
void op_indget(mval *dst, mval *target, mval *value) { icode_str indir_src; int rval; ht_ent_mname *tabent; mstr *obj, object; oprtype v; triple *s, *src, *oldchain, tmpchain, *r, *triptr; var_tabent targ_key; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; if ((TREF(ind_source_sp) >= TREF(ind_source_top)) || (TREF(ind_result_sp) >= TREF(ind_result_top))) rts_error(VARLSTCNT(1) ERR_INDMAXNEST); /* mdbcondition_handler resets ind_result_sp & ind_source_sp */ MV_FORCE_DEFINED(value); MV_FORCE_STR(target); indir_src.str = target->str; indir_src.code = indir_get; if (NULL == (obj = cache_get(&indir_src))) { obj = &object; if (valid_mname(&target->str)) { targ_key.var_name = target->str; COMPUTE_HASH_MNAME(&targ_key); tabent = lookup_hashtab_mname(&curr_symval->h_symtab, &targ_key); if (!tabent || !LV_IS_VAL_DEFINED(tabent->value)) *dst = *value; else *dst = ((lv_val *)tabent->value)->v; dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */ return; } comp_init(&target->str); src = newtriple(OC_IGETSRC); switch (TREF(window_token)) { case TK_IDENT: if (EXPR_FAIL != (rval = lvn(&v, OC_SRCHINDX, 0))) /* NOTE assignment */ { s = newtriple(OC_FNGET2); s->operand[0] = v; s->operand[1] = put_tref(src); } break; case TK_CIRCUMFLEX: if (EXPR_FAIL != (rval = gvn())) /* NOTE assignment */ { r = newtriple(OC_FNGVGET1); s = newtriple(OC_FNGVGET2); s->operand[0] = put_tref(r); s->operand[1] = put_tref(src); } break; case TK_ATSIGN: TREF(saw_side_effect) = TREF(shift_side_effects); if (TREF(shift_side_effects) && (GTM_BOOL == TREF(gtm_fullbool))) { dqinit(&tmpchain, exorder); oldchain = setcurtchain(&tmpchain); if (EXPR_FAIL != (rval = indirection(&v))) /* NOTE assignment */ { s = newtriple(OC_INDGET); s->operand[0] = v; s->operand[1] = put_tref(src); newtriple(OC_GVSAVTARG); setcurtchain(oldchain); dqadd(TREF(expr_start), &tmpchain, exorder); TREF(expr_start) = tmpchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } else setcurtchain(oldchain); } else { if (EXPR_FAIL != (rval = indirection(&v))) /* NOTE assignment */ { s = newtriple(OC_INDGET); s->operand[0] = v; s->operand[1] = put_tref(src); } } break; default: stx_error(ERR_VAREXPECTED); rval = EXPR_FAIL; break; } v = put_tref(s); if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &v, target->str.len)) return; indir_src.str.addr = target->str.addr; cache_put(&indir_src, obj); /* Fall into code activation below */ } *(TREF(ind_result_sp))++ = dst; *(TREF(ind_source_sp))++ = value; comp_indr(obj); return; }
int exfunc (oprtype *a) { triple *ref0, *calltrip, *masktrip, *counttrip, *funret, *tripsize; triple *triptr; triple tmpchain, *oldchain, *obp, *routineref, *labelref; error_def (ERR_ACTOFFSET); assert (window_token == TK_DOLLAR); advancewindow(); assert (window_token == TK_DOLLAR); advancewindow(); dqinit (&tmpchain, exorder); oldchain = setcurtchain (&tmpchain); calltrip = entryref (OC_EXFUN, OC_EXTEXFUN, INDIR_DUMMY, TRUE, TRUE); setcurtchain (oldchain); if (!calltrip) return FALSE; if (calltrip->opcode == OC_EXFUN) { assert(calltrip->operand[0].oprclass == MLAB_REF); ref0 = newtriple(OC_PARAMETER); ref0->operand[0] = put_tsiz(); /* Need size of following code gen triple here */ calltrip->operand[1] = put_tref(ref0); tripsize = ref0->operand[0].oprval.tref; assert(OC_TRIPSIZE == tripsize->opcode); } else { if (calltrip->opcode == OC_EXTEXFUN) { assert (calltrip->operand[1].oprclass == TRIP_REF); if (calltrip->operand[1].oprval.tref->opcode == OC_CDLIT) assert (calltrip->operand[1].oprval.tref->operand[0].oprclass == CDLT_REF); else { assert (calltrip->operand[1].oprval.tref->opcode == OC_LABADDR); assert (calltrip->operand[1].oprval.tref->operand[1].oprclass == TRIP_REF); assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode == OC_PARAMETER); assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass == TRIP_REF); assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->opcode == OC_ILIT); assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprclass == ILIT_REF); if (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprval.ilit != 0) { stx_error (ERR_ACTOFFSET); return FALSE; } } } else /* $$ @dlabel [actuallist] */ { assert (calltrip->opcode == OC_COMMARG); assert (calltrip->operand[1].oprclass == TRIP_REF); assert (calltrip->operand[1].oprval.tref->opcode == OC_ILIT); assert (calltrip->operand[1].oprval.tref->operand[0].oprclass == ILIT_REF); assert (calltrip->operand[1].oprval.tref->operand[0].oprval.ilit == INDIR_DUMMY); assert (calltrip->exorder.fl == &tmpchain); routineref = maketriple (OC_CURRHD); labelref = maketriple (OC_LABADDR); ref0 = maketriple (OC_PARAMETER); dqins (calltrip->exorder.bl, exorder, routineref); dqins (calltrip->exorder.bl, exorder, labelref); dqins (calltrip->exorder.bl, exorder, ref0); labelref->operand[0] = calltrip->operand[0]; labelref->operand[1] = put_tref (ref0); ref0->operand[0] = calltrip->operand[1]; ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0; ref0->operand[1] = put_tref (routineref); calltrip->operand[0] = put_tref (routineref); calltrip->operand[1] = put_tref (labelref); calltrip->opcode = OC_EXTEXFUN; } ref0 = newtriple (OC_PARAMETER); ref0->operand[0] = calltrip->operand[1]; calltrip->operand[1] = put_tref (ref0); } if (window_token != TK_LPAREN) { masktrip = newtriple (OC_PARAMETER); counttrip = newtriple (OC_PARAMETER); masktrip->operand[0] = put_ilit (0); counttrip->operand[0] = put_ilit (0); masktrip->operand[1] = put_tref (counttrip); ref0->operand[1] = put_tref (masktrip); } else if (!actuallist (&ref0->operand[1])) return FALSE; obp = oldchain->exorder.bl; dqadd (obp, &tmpchain, exorder); /*this is a violation of info hiding*/ if (calltrip->opcode == OC_EXFUN) { assert(calltrip->operand[0].oprclass == MLAB_REF); triptr = newtriple (OC_JMP); triptr->operand[0] = put_mfun (&calltrip->operand[0].oprval.lab->mvname); calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */ tripsize->operand[0].oprval.tsize->ct = triptr; } funret = newtriple (OC_EXFUNRET); funret->operand[0] = *a = put_tref (calltrip); return TRUE; }
int compile_pattern(oprtype *opr, boolean_t is_indirect) { int status; ptstr retstr; mval retmval; mstr instr; triple *oldchain, *ref, tmpchain, *triptr; DCL_THREADGBL_ACCESS; SETUP_THREADGBL_ACCESS; if (is_indirect) { 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(opr)) { setcurtchain(oldchain); return FALSE; } ref = newtriple(OC_INDPAT); newtriple(OC_GVSAVTARG); setcurtchain(oldchain); dqadd(TREF(expr_start), &tmpchain, exorder); TREF(expr_start) = tmpchain.exorder.bl; triptr = newtriple(OC_GVRECTARG); triptr->operand[0] = put_tref(TREF(expr_start)); } else { if (!indirection(opr)) return FALSE; ref = newtriple(OC_INDPAT); } ref->operand[0] = *opr; *opr = put_tref(ref); return TRUE; } else { instr.addr = (char *)&source_buffer[source_column - 1]; instr.len = STRLEN(instr.addr); status = patstr(&instr, &retstr, NULL); TREF(last_source_column) = (short int)(instr.addr - (char *)source_buffer); assert(TREF(last_source_column)); if (status) { /* status == syntax error when non-zero */ stx_error(status); return FALSE; } retmval.mvtype = MV_STR; retmval.str.len = retstr.len * SIZEOF(uint4); retmval.str.addr = (char *)stringpool.free; ENSURE_STP_FREE_SPACE(retmval.str.len); memcpy(stringpool.free, &retstr.buff[0], retmval.str.len); stringpool.free += retmval.str.len; *opr = put_lit(&retmval); lexical_ptr = instr.addr; advancewindow(); advancewindow(); return TRUE; } }